home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ADA Programming Guide
/
ADA Programming Guide.iso
/
adatutor
/
csparts
/
csparts.src
< prev
Wrap
Text File
|
1996-01-30
|
453KB
|
11,227 lines
--::::::::::
--types.spc
--::::::::::
-- ***************************************************
-- * *
-- * CS_Parts_Types * SPEC
-- * *
-- ***************************************************
package CS_Parts_Types is
--| Purpose
--| Provide common type definitions for items in CS_Parts
--| and useful conversion utilities.
--|
--| Initialization Exceptions (none)
--| Notes
--| Not all MIL-HDBK-1804 PDL annotations are
--| used in this package due to its simplicity.
--| No exceptions are raised in this package.
--|
--| Modifications
--| 07/15/90 Rick Conn Initial Design and Code
type BYTE is range 16#0# .. 16#FF#;
for BYTE'SIZE use 8;
-- ...................................................
-- . .
-- . CS_Parts_Types.Convert . SPEC
-- . .
-- ...................................................
function Convert (Item : in CHARACTER) return BYTE;
--| Purpose
--| Convert a CHARACTER into a BYTE.
-- ...................................................
-- . .
-- . CS_Parts_Types.Convert . SPEC
-- . .
-- ...................................................
function Convert (Item : in INTEGER) return BYTE;
--| Purpose
--| Convert an INTEGER into a BYTE. If the
--| INTEGER is greater than 255, only the low-order
--| BYTE is converted.
-- ...................................................
-- . .
-- . CS_Parts_Types.Convert . SPEC
-- . .
-- ...................................................
function Convert (Item : in BYTE) return CHARACTER;
--| Purpose
--| Convert a BYTE into a CHARACTER. If the most
--| significant bit of the BYTE is set, it is cleared
--| as the CHARACTER.
-- ...................................................
-- . .
-- . CS_Parts_Types.Convert . SPEC
-- . .
-- ...................................................
function Convert (Item : in BYTE) return INTEGER;
--| Purpose
--| Convert a BYTE into a INTEGER.
end CS_Parts_Types;
--::::::::::
--console.spc
--::::::::::
-- *********************************************************
-- * *
-- * Console * SPEC
-- * *
-- *********************************************************
package Console is
--| Purpose
--| Console provides a set of I/O and screen control commands
--| for either IBM PC computers employing the ANSI.SYS device
--| driver or the VT100-compatible family of terminals. By using
--| this package, a programmer may manipulate the terminal screen
--| regardless if it is an IBM PC with ANSI.SYS or a VT100 terminal.
--|
--| The console object runs in one of three modes:
--| TTY All screen-oriented commands are disabled
--| VT100 All screen-oriented commands except display
--| color control (foreground and background)
--| are enabled
--| ANSI All screen-oriented commands are enabled
--| The default mode is TTY, and the mode of the console object
--| can be changed at any time by calling the Set_Terminal
--| routine.
--|
--| The output to the console object can be enabled or disabled
--| by using the Enable_Output and Disable_Output routines.
--| The Push and Pop routines can be used to preserve the current
--| state of the console and restore the console to the previous
--| state.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| 3/8/91 Richard Conn Initial Release
Max_Number_of_States : constant NATURAL := 10;
-- number of enable/disable states to the console; also,
-- number of Push calls before a State_Overflow exception
type TERMINAL_KIND is (TTY, -- no screen-oriented commands
ANSI, -- colors supported
VT100 -- no colors
);
type ROW_NUMBER is new INTEGER range 1..24;
type COLUMN_NUMBER is new INTEGER range 1..80;
type RENDITION is
(ALL_ATTRIBUTES_OFF, -- ANSI.SYS or VT100
HIGH_INTENSITY,
BLINKING,
REVERSE_VIDEO,
FOREGROUND_BLACK, -- ANSI.SYS only
FOREGROUND_RED,
FOREGROUND_GREEN,
FOREGROUND_YELLOW,
FOREGROUND_BLUE,
FOREGROUND_MAGENTA,
FOREGROUND_CYAN,
FOREGROUND_WHITE,
BACKGROUND_BLACK,
BACKGROUND_RED,
BACKGROUND_GREEN,
BACKGROUND_YELLOW,
BACKGROUND_BLUE,
BACKGROUND_MAGENTA,
BACKGROUND_CYAN,
BACKGROUND_WHITE);
for RENDITION'Size use INTEGER'Size;
for RENDITION use
(ALL_ATTRIBUTES_OFF => 0, -- ANSI.SYS or VT100
HIGH_INTENSITY => 1,
BLINKING => 5,
REVERSE_VIDEO => 7,
FOREGROUND_BLACK => 30, -- ANSI.SYS only
FOREGROUND_RED => 31,
FOREGROUND_GREEN => 32,
FOREGROUND_YELLOW => 33,
FOREGROUND_BLUE => 34,
FOREGROUND_MAGENTA => 35,
FOREGROUND_CYAN => 36,
FOREGROUND_WHITE => 37,
BACKGROUND_BLACK => 40,
BACKGROUND_RED => 41,
BACKGROUND_GREEN => 42,
BACKGROUND_YELLOW => 43,
BACKGROUND_BLUE => 44,
BACKGROUND_MAGENTA => 45,
BACKGROUND_CYAN => 46,
BACKGROUND_WHITE => 47);
type OVERFLOW_ACTION is -- used for a Put(STRING)
(TRUNCATE_HEAD, -- ABC becomes "BC"
TRUNCATE_TAIL, -- ABC becomes "AB"
FILL_WITH_OVERFLOW_CHAR -- ABC becomes "**"
);
type NUMERIC_OVERFLOW_ACTION is -- used for a Put(INTEGER)
(FILL_WITH_OVERFLOW_CHAR, -- 123 becomes "**"
OUTPUT_FULL_NUMBER -- 123 becomes "123"
);
type JUSTIFICATION is -- used for a Put(STRING)
(LEFT_JUSTIFIED, -- ABC becomes "ABC "
RIGHT_JUSTIFIED -- ABC becomes " ABC"
);
INPUT_ERROR : exception; -- raised on invalid input
STATE_OVERFLOW : exception;
-- raised if the Max_Number_of_States is exceeded
STATE_UNDERFLOW : exception;
-- raised if too many Pop routine calls are made
-- .................................................................
-- . .
-- . Console.Set_Terminal . SPEC
-- . .
-- .................................................................
procedure Set_Terminal (New_Setting : in TERMINAL_KIND := TTY);
--| Purpose
--| Define the kind of user's terminal. If this routine is not
--| called, TTY is assumed.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Enable_Output . SPEC
-- . .
-- .................................................................
procedure Enable_Output;
--| Purpose
--| Enable the output routines of the console object (affects current
--| state only). These routines include Position_Cursor, Erase_Display,
--| Erase_Line, Set_Rendition, all the Put and Put_Line routines, and
--| New_Line.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Disable_Output . SPEC
-- . .
-- .................................................................
procedure Disable_Output;
--| Purpose
--| Disable the output routines of the console object (affects current
--| state only). These routines include Position_Cursor, Erase_Display,
--| Erase_Line, Set_Rendition, all the Put and Put_Line routines, and
--| New_Line.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Push . SPEC
-- . .
-- .................................................................
procedure Push;
--| Purpose
--| Increment to the next state (environment) of the console object.
--| All states are initialized to be enabled. This routine permits,
--| for example, a console to be turned off for silent running and
--| then temporarily turned on for an error message display. The
--| console object stays in this new state, which may be altered by
--| the Enable_Output and Disable_Output routines, until a Pop is
--| executed.
--|
--| Exceptions
--| STATE_OVERFLOW -- raised if Max_Number_of_States is exceeded
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Pop . SPEC
-- . .
-- .................................................................
procedure Pop;
--| Purpose
--| Decrement to the previous state (environment) of the console object.
--| All states are initialized to be enabled. See the Push routine
--| for more details.
--|
--| Exceptions
--| STATE_UNDERFLOW -- raised if current state tries to drop below 0
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Position_Cursor . SPEC
-- . .
-- .................................................................
procedure Position_Cursor (Row : in ROW_NUMBER;
Column : in COLUMN_NUMBER);
--| Purpose
--| Position the cursor to the indicated Row and Column. Row 1,
--| Column 1 is the upper left corner of the screen.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Erase_Display . SPEC
-- . .
-- .................................................................
procedure Erase_Display;
--| Purpose
--| Erase the entire display and place the cursor at the home position.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Erase_Line . SPEC
-- . .
-- .................................................................
procedure Erase_Line;
--| Purpose
--| Erase from the cursor to the end of the line.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Set_Rendition . SPEC
-- . .
-- .................................................................
procedure Set_Rendition (New_Setting : in RENDITION);
--| Purpose
--| Add the indicated New_Setting to the current graphics display
--| rendition (default is ALL_ATTRIBUTES_OFF). Calls to this procedure
--| are cumulative until all attributes are turned off.
--|
--| Exceptions (none)
--|
--| Notes
--| Color selections are ignored on a VT100 compatible terminal.
-- .................................................................
-- . .
-- . Console.Put . SPEC
-- . .
-- .................................................................
procedure Put (Item : in CHARACTER);
procedure Put (Item : in STRING);
--| Purpose
--| Output a character or a string to the console.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Put . SPEC
-- . .
-- .................................................................
procedure Put
( Item : in STRING;
Field_Width : in NATURAL;
On_Overflow : in OVERFLOW_ACTION := TRUNCATE_TAIL;
On_Underflow : in JUSTIFICATION := LEFT_JUSTIFIED;
Fill_Char : in CHARACTER := ' ';
Overflow_Char : in CHARACTER := '*' );
--| Purpose
--| Output a string to the console in a field of a given
--| Field_Width.
--| If Item is shorter than Field_Width,
--| the On_Underflow flag takes effect, justifying Item
--| in the field as indicated using the Fill_Char.
--| If Item is longer than Field_Width, the On_Overflow
--| flag takes effect, either truncating Item on the left or
--| right or filling the field with the Overflow_Char.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Put . SPEC
-- . .
-- .................................................................
procedure Put (Item : in INTEGER;
Width : in NATURAL;
On_Overflow : in NUMERIC_OVERFLOW_ACTION
:= FILL_WITH_OVERFLOW_CHAR;
Overflow_Char : in CHARACTER := '*');
--| Purpose
--| Output an integer to the console. It will be placed in a
--| field that is Width characters long. Width of 0 fits the
--| INTEGER exactly. If the resulting sequence of characters
--| has fewer than Width characters, then leading spaces are
--| first output to make up the difference. If the resulting
--| sequence of characters has more than Width characters,
--| then the On_Overflow flag takes effect.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Put . SPEC
-- . .
-- .................................................................
procedure Put (Item : in FLOAT;
Fore : in NATURAL;
Aft : in NATURAL;
On_Overflow : in NUMERIC_OVERFLOW_ACTION
:= FILL_WITH_OVERFLOW_CHAR;
Overflow_Char : in CHARACTER := '*');
--| Purpose
--| Output a floating point number to the console. Fore is the
--| number of characters to be displayed before the decimal point,
--| and Aft is the number of characters to be displayed after the
--| decimal point. Item's value appears as follows:
--|
--| Fore Aft fields
--| ---- --- (Fore=4, Aft=3)
--| nnnn.nnn if Item is positive
--| -nnn.nnn if Item is negative
--| ******** if overflow with defaults
--|
--| If Item is negative, a leading minus sign, which counts as
--| one of the characters in the Fore field, is output.
--| If -1.0 < Item < 1.0, then -0 or 0 is output in the Fore
--| field.
--| If the number of digits required to display Item in the Fore
--| field exceeds the value of Fore (i.e., is too big), the
--| On_Overflow flag takes effect, either overriding Fore or filling
--| the field with the Overflow_Char.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Put . SPEC
-- . .
-- .................................................................
procedure Put (Item : in FLOAT;
Fore : in NATURAL := 2;
Aft : in NATURAL := 2;
Exp : in NATURAL := 3);
--| Purpose
--| Output a floating point number in scientific notation
--| to the console. Fore is the number of characters to be
--| displayed before the decimal point (only one digit and
--| a sign are displayed, so rest of Fore characters are
--| leading spaces), Aft is the number of characters to be
--| displayed after the decimal point, and Exp is the number
--| of characters in the exponent. Item's value appears as:
--|
--| -- ---- --- (Fore=2, Aft=4, Exp=3)
--| n.nnnnE+nn if Item is positive
--| -n.nnnnE+nn if Item is negative
--|
--| The Fore field will always contain a single digit with
--| an optional minus sign. If Fore > 2, leading spaces are
--| prefixed to the output. Hence, Put(-123.0, 4, 2, 3) outputs
--| " -1.23E+02".
--| Exp is the size of the field for the number after the "E".
--| This field always includes a leading sign (see -123.0 example
--| above).
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Put_Line . SPEC
-- . .
-- .................................................................
procedure Put_Line (Item : in STRING);
--| Purpose
--| Output a string followed by a new line to the console.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.New_Line . SPEC
-- . .
-- .................................................................
procedure New_Line;
--| Purpose
--| Output a new line to the console.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................................
-- . .
-- . Console.Get . SPEC
-- . .
-- .................................................................
procedure Get
( Item : out CHARACTER);
procedure Get
( Item : out INTEGER);
procedure Get
( Item : out FLOAT);
--| Purpose
--| Get views the Console input as a stream and
--| returns the next Item of the appropriate type
--| from it.
--|
--| Exceptions
--| Input_Error raised if the next item
--| in the stream is not of the
--| correct type when translated
--| from the characters or if the
--| translation process encounters
--| an error condition
--|
--| Notes
--| If the Item is of type INTEGER or FLOAT, Get
--| skips over whitespace characters (blank, tab, new
--| line) first and then starts translating at the
--| first non-white character encountered.
--| If the Item is of type CHARACTER, Get returns
--| the next character, whitespace or not.
-- .................................................................
-- . .
-- . Console.Get_Line . SPEC
-- . .
-- .................................................................
procedure Get_Line
( Item : out STRING;
Last : out NATURAL );
--| Purpose
--| Get_Line reads a line from the console.
--|
--| Exceptions (none)
--| Notes (none)
end Console;
--::::::::::
--bintree.spc
--::::::::::
-- ********************************************************
-- * *
-- * BINARY_TREES_PKG * SPEC
-- * *
-- ********************************************************
generic
type VALUE_TYPE is private;
with function Difference(P, Q: VALUE_TYPE) return integer is <>;
-- Must return a value > 0 if P > Q, 0 if P = Q, and less than
-- zero otherwise.
package Binary_Trees_Pkg is
--| Purpose
--| This package is an efficient implementation of unbalanced binary trees.
--| These trees have the following properties:
--|
--| 1. Inserting a value is cheap (log n Differences per insertion).
--| 2. Finding a value is cheap (log n Differences per querey).
--| 3. Can iterate over the values in sorted order in linear time.
--| 4. Space overhead is moderate (2 "pointers" per value stored).
--|
--| They are thus useful both for sorting sequences of indeterminate size
--| and for lookup tables.
--|
--| Initialization Exceptions (none)
--| Notes
--| The following example shows how to use this package where nodes in
--| the tree are labeled with a String_Type value (for which a natural
--| Difference function is not available).
--|-
--| package SP renames String_Pkg;
--|
--| type my_Value is record
--| label: SP.string_type;
--| value: integer;
--| end record;
--|
--| function differ_label(P, Q: SP.string_type) return integer is
--| begin
--| if SP."<"(P, Q) then return -1;
--| elsif SP."<"(Q, P) then return 1;
--| else return 0;
--| end if;
--| end differ_label;
--|
--| package my_Tree is new Binary_Trees_pkg(my_Value, differ_Label);
--|
--| Note that the required Difference function may be easily written in terms
--| of "<" if that is available, but that frequently two comparisons must
--| be done for each Difference. However, both comparisons would have
--| to be done internally by this package for every instantiation if the
--| generic parameter were "<" instead of Difference.
--|
--| PERFORMANCE
--|
--| Every node can be visited in the tree in linear time. The cost
--| of creating an iterator is small and independent of the size
--| of the tree.
--|
--| Recognizing that comparing values can be expensive, this package
--| takes a Difference function as a generic parameter. If it took
--| a comparison function such as "<", then two comparisons would be
--| made per node visited during a search of the tree. Of course this
--| is more costly when "<" is a trivial operation, but in those cases,
--| Difference can be bound to "-" and the overhead in negligable.
--|
--| Two different kinds of iterators are provided. The first is the
--| commonly used set of functions Make_Iter, More, and Next. The second
--| is a generic procedure called Visit. The generic parameter to Visit is
--| a procedure which is called once for each value in the tree. Visit
--| is more difficult to use and results in code that is not quite as clear,
--| but its overhead is about 20% of the More/Next style iterator. It
--| is therefore recommended for use only in time critical inner loops.
--|
--| Modifications
--| Author: Bill Toscano and Michael Gordon, Intermetrics, Inc.
-- Exceptions --
Duplicate_Value: exception;
-- Raised on attempt to insert a duplicate node into a tree.
Not_Found: exception;
-- Raised on attempt to find a node that is not in a tree.
No_More: exception;
-- Raised on attempt to bump an iterator that has already scanned the
-- entire tree.
Out_Of_Order: exception;
-- Raised if a problem in the ordering of a tree is detected.
Invalid_Tree: exception;
-- Value is not a tree or was not properly initialized.
-- Types --
type SCAN_KIND is (INORDER, PREORDER, POSTORDER);
-- Used to specify the order in which values should be scanned from a tree:
--
-- inorder: Left, Node, Right (nodes visited in increasing order)
-- preorder: Node, Left, Right (top down)
-- postorder: Left, Right, Node (bottom up)
type TREE is private;
type ITERATOR is private;
-- Operations --
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.CREATE . SPEC
-- . .
-- .....................................................
Function Create return TREE;
--| Purpose
--| Create and return an empty tree. Note that this allocates
--| a small amount of storage which can only be reclaimed through
--| a call to Destroy.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.INSERT . SPEC
-- . .
-- .....................................................
Procedure Insert (V: VALUE_TYPE;
T: TREE);
--| Purpose
--| Insert V into T in the proper place. If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, the exception Duplicate_Value is raised.
--| Caution: Since this package does not attempt to balance trees as
--| values are inserted, it is important to remember that inserting
--| values in sorted order will create a degenerate tree, where search
--| and insertion is proportional to the N instead of to Log N. If
--| this pattern is common, use the Balanced_Tree function below.
--|
--| Exceptions
--| Duplicate_Value
--| Invalid_Tree
--|
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.INSERT_IF_NOT_FOUND . SPEC
-- . .
-- .....................................................
procedure Insert_if_not_Found (V : VALUE_TYPE;
T : TREE;
Found : out BOOLEAN;
Duplicate : out VALUE_TYPE);
--| Purpose
--| Insert V into T in the proper place. If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, Found will be True and Duplicate will be the duplicate
--| value. This might be a sequence of values with the same key, and
--| V can then be added to the sequence.
--|
--| Exceptions
--| Invalid_Tree.
--|
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.REPLACE_IF_FOUND . SPEC
-- . .
-- .....................................................
procedure Replace_if_Found (V : VALUE_TYPE;
T : TREE;
Found : out BOOLEAN;
Old_Value : out VALUE_TYPE);
--| Purpose
--| Search for V in T. If found, replace the old value with V,
--| and return Found => True, Old_Value => the old value. Otherwise,
--| simply insert V into T and return Found => False.
--|
--| Exceptions
--| Invalid_Tree.
--|
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.DESTROY . SPEC
-- . .
-- .....................................................
procedure Destroy (T: in out TREE);
--| Purpose
--| The space allocated to T is reclaimed. The space occupied by
--| the values stored in T is not however, recovered.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.DESTROY_DEEP . SPEC
-- . .
-- .....................................................
generic
with procedure Free_Value(V: in out VALUE_TYPE) is <>;
procedure Destroy_Deep (T: in out TREE);
--| Purpose
--| The space allocated to T is reclaimed. The values stored
--| in T are reclaimed using Free_Value, and the tree nodes themselves
--| are then reclaimed (in a single walk of the tree).
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.BALANCED_TREE . SPEC
-- . .
-- .....................................................
generic
with function Next_Value return VALUE_TYPE is <>;
-- Each call to this procedure should return the next value to be
-- inserted into the balanced tree being created. If necessary,
-- this function should check that each value is greater than the
-- previous one, and raise Out_of_Order if necessary. If values
-- are not returned in strictly increasing order, the results are
-- unpredictable.
Function Balanced_Tree (Count: NATURAL) return TREE;
--| Purpose
--| Create a balanced tree by calling next_Value Count times.
--| Each time Next_Value is called, it must return a value that compares
--| greater than the preceeding value. This function is useful for balancing
--| an existing tree (next_Value iterates over the unbalanced tree) or
--| for creating a balanced tree when reading data from a file which is
--| already sorted.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.COPY_TREE . SPEC
-- . .
-- .....................................................
generic
with function Copy_Value(V: VALUE_TYPE) return VALUE_TYPE is <>;
-- This function is called to copy a value from the old tree to the
-- new tree.
Function Copy_Tree (T: TREE) return TREE;
--| Purpose
--| Create a balanced tree that is a copy of the tree T.
--| The exception Invalid_Tree is raised if T is not a valid tree.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.IS_EMPTY . SPEC
-- . .
-- .....................................................
Function Is_Empty (T: TREE) return BOOLEAN;
--| Purpose
--| Return TRUE iff T is an empty tree or if T was not initialized.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.FIND . SPEC
-- . .
-- .....................................................
Function Find (V: VALUE_TYPE;
T: TREE) return VALUE_TYPE;
--| Purpose
--| Search T for a value that matches V. The matching value is
--| returned. If no matching value is found, the exception Not_Found
--| is raised.
--|
--| Exceptions
--| Not_Found
--| Invalid_Tree
--|
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.FIND . SPEC
-- . .
-- .....................................................
Procedure Find (V : VALUE_TYPE;
T : TREE;
Found : out BOOLEAN;
Match : out VALUE_TYPE);
--| Purpose
--| Search T for a value that matches V. On return, if Found is
--| TRUE then the matching value is returned in Match. Otherwise, Found
--| is FALSE and Match is undefined.
--|
--| Exceptions
--| Invalid_Tree;
--|
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.IS_FOUND . SPEC
-- . .
-- .....................................................
function Is_Found (V: VALUE_TYPE;
T: TREE) return BOOLEAN;
--| Purpose
--| Return TRUE iff V is found in T.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.SIZE . SPEC
-- . .
-- .....................................................
function Size (T: TREE) return NATURAL;
--| Purpose
--| Return the number of values stored in T.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.VISIT . SPEC
-- . .
-- .....................................................
generic
with procedure Process(V: VALUE_TYPE) is <>;
procedure Visit (T : TREE;
Order : SCAN_KIND);
--| Purpose
--| Invoke Process(V) for each value V in T. The nodes are visited
--| in the order specified by Order. Although more limited than using
--| an iterator, this function is also much faster.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.MAKE_ITER . SPEC
-- . .
-- .....................................................
function Make_Iter (T: TREE) return ITERATOR;
--| Purpose
--| Create an iterator over a tree.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.MORE . SPEC
-- . .
-- .....................................................
function More (I: ITERATOR) return BOOLEAN;
--| Purpose
--| Return TRUE iff unscanned nodes remain in the tree being
--| scanned by I.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . BINARY_TREES_PKG.NEXT . SPEC
-- . .
-- .....................................................
procedure Next (I: in out ITERATOR;
V: out VALUE_TYPE);
--| Purpose
--| Return the next value in the tree being scanned by I.
--| The exception No_More is raised if there are no more values to scan.
--|
--| Exceptions
--| No_More
--|
--| Notes (none)
private
type NODE;
type NODE_PTR is access NODE;
type NODE is
record
Value : VALUE_TYPE;
Less : NODE_PTR;
More : NODE_PTR;
end record;
type TREE_HEADER is
record
Count : NATURAL := 0;
Root : NODE_PTR := Null;
end record;
type TREE is access TREE_HEADER;
type ITER_STATE is (LEFT, MIDDLE, RIGHT, DONE);
type ITERATOR_RECORD;
type ITERATOR is access ITERATOR_RECORD;
type ITERATOR_RECORD is
record
State : ITER_STATE;
Parent : ITERATOR;
Subtree : NODE_PTR;
end record;
end Binary_Trees_Pkg;
--::::::::::
--bit.spc
--::::::::::
-- ***************************************************************
-- * *
-- * BIT_FUNCTIONS * SPEC
-- * *
-- ***************************************************************
package Bit_Functions is
--| Purpose
--| This package allows the Ada programmer to manipulate the bits
--| within an object of type INTEGER. The bits are numbers from
--| the right to the left, starting with number zero.
--|
--| +------------------------+
--| + 15 14 13 ... 3 2 1 0 !
--| +------------------------+
--|
--| In each routine, the number of bits being manipulated
--| is NBITS. START_AT identifies the right most bit of NBITS field.
--|
--| e.g.
--| ... 6 5 4 3 2 1 0
--| X X X nbits = 3
--| start_at = 2
--|
--| Initialization Exceptions (none)
--| Notes
--| Not all MIL-HDBK-1804 PDL annotations are
--| used in this package due to its simplicity.
--| No exceptions are raised by this package.
--|
--| Modifications
--| Author: Freeman Moore, TI
-- ..................................................................
-- . .
-- . BIT_FUNCTIONS.BIT_EXTRACT . SPEC
-- . .
-- ..................................................................
function Bit_Extract (Item, Start_At, Nbits : INTEGER) return INTEGER;
--| Purpose
--| Return the bit field extracted from ITEM, as a signed integer.
-- ..................................................................
-- . .
-- . BIT_FUNCTIONS.UBIT_EXTRACT . SPEC
-- . .
-- ..................................................................
function Ubit_Extract (Item, Start_At, Nbits : INTEGER) return INTEGER;
--| Purpose
--| Return the bit field extracted from ITEM, unsigned integer.
-- ..................................................................
-- . .
-- . BIT_FUNCTIONS.BIT_INSERT . SPEC
-- . .
-- ..................................................................
function Bit_Insert (This_Item, Nbits, Into_Item, Start_At : INTEGER)
return INTEGER;
--| Purpose
--| Insert NBITS from THIS_ITEM into the object INTO_ITEM,
--| with the rightmost bit identified by START_AT.
-- ..................................................................
-- . .
-- . BIT_FUNCTIONS.BIT_REMOVE . SPEC
-- . .
-- ..................................................................
function Bit_Remove (Item, Start_At, Nbits : INTEGER) return INTEGER;
--| Purpose
--| BIT_REMOVE will zero out NBITS of ITEM at position START_AT.
-- ..................................................................
-- . .
-- . BIT_FUNCTIONS.SHIFT_LEFT . SPEC
-- . .
-- ..................................................................
function Shift_Left (Item, Nbits : INTEGER) return INTEGER;
--| Purpose
--| Return ITEM shifted left by NBITS.
-- ..................................................................
-- . .
-- . BIT_FUNCTIONS.SHIFT_RIGHT . SPEC
-- . .
-- ..................................................................
function Shift_Right (Item, Nbits : INTEGER) return INTEGER;
--| Purpose
--| Return ITEM shifted right by NBITS.
-- ..................................................................
-- . .
-- . BIT_FUNCTIONS.BIT_AND . SPEC
-- . .
-- ..................................................................
function Bit_AND (Word1, Word2 : INTEGER) return INTEGER;
--| Purpose
--| Return the AND of the two objects.
-- ..................................................................
-- . .
-- . BIT_FUNCTIONS.BIT_OR . SPEC
-- . .
-- ..................................................................
function Bit_OR (Word1, Word2 : INTEGER) return INTEGER;
--| Purpose
--| Return the OR of the two objects.
-- ..................................................................
-- . .
-- . BIT_FUNCTIONS.BIT_MASK . SPEC
-- . .
-- ..................................................................
function Bit_Mask (Nbits : INTEGER) return INTEGER;
--| Purpose
--| Return an object with NBITS of one bits, right justified.
end Bit_Functions;
--::::::::::
--bplustre.spc
--::::::::::
-- **********************************************************
-- * *
-- * BP_Tree * SPEC
-- * *
-- **********************************************************
generic
type KEY_TYPE is limited private;
type NON_KEY_ITEM_TYPE is limited private;
type NON_KEY_ITEM_CONTAINER is limited private;
with function Empty
(This_Non_Key_Item_Container : in NON_KEY_ITEM_CONTAINER)
return Boolean is <>;
with procedure Assign
(To_Non_Key_Item_Container : in out NON_KEY_ITEM_CONTAINER;
From_Non_Key_Item_Container : in NON_KEY_ITEM_CONTAINER)
is <>;
with procedure Insert
(Container : in out NON_KEY_ITEM_CONTAINER;
Non_Key_Item : in NON_KEY_ITEM_TYPE ) is <>;
with procedure Delete
(Container : in out NON_KEY_ITEM_CONTAINER;
Non_Key_Item : in NON_KEY_ITEM_TYPE ) is <>;
with procedure Destroy_Contents
(This_Non_Key_Item_Container : in out NON_KEY_ITEM_CONTAINER)
is <>;
-- This procedure must destroy everything in the container
-- in preparation for the destruction of the container itself.
with procedure Assign (Target_Key : in out KEY_TYPE;
Source_Key : in KEY_TYPE) is <>;
with function Less_Than (First_Key : in KEY_TYPE;
Second_Key : in KEY_TYPE)
return Boolean is <>;
with function Equal (First_Key : in KEY_TYPE;
Second_Key : in KEY_TYPE)
return Boolean is <>;
package BP_Tree is
--| Purpose
--| Implement a B+ Tree class of objects.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: William Thomas Wolfe, Clemson University
-- *******************************************************
-- This software is part of the Clemson University
-- Computer Science Department's Ada Software
-- Repository, and is copyrighted (C) 1989 by
-- Clemson University. Permission to copy without
-- fee all or part of this software is granted,
-- provided that the copies are not made or
-- distributed for direct commercial advantage, and
-- that this copyright notice is not deleted or
-- modified. To copy otherwise, or to republish,
-- requires a fee and/or specific permission.
-- *******************************************************
type B_PLUS_TREE is limited private;
Key_Does_Not_Exist_In_This_B_Plus_Tree : EXCEPTION;
No_Preceding_Key_Exists_In_This_B_Plus_Tree : EXCEPTION;
No_Following_Key_Exists_In_This_B_Plus_Tree : EXCEPTION;
No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree : EXCEPTION;
type POINTER_TO_B_PLUS_TREE is access B_PLUS_TREE;
-- ....................................................
-- . .
-- . BP_Tree.Destroy . SPEC
-- . .
-- ....................................................
procedure Destroy
(Targeted_Object : in out POINTER_TO_B_PLUS_TREE);
--| Purpose
--| Unlike Unchecked_Deallocation, this procedure will properly
--| destroy the B_Plus_Tree pointed to.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Insert_Item . SPEC
-- . .
-- ....................................................
procedure Insert_Item
(Targeted_B_Plus_Tree : in out B_PLUS_TREE;
Key_Value : in KEY_TYPE;
Non_Key_Information : in NON_KEY_ITEM_TYPE);
--| Purpose
--| Insert an element into the Targeted_B_Plus_Tree.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Delete_Item . SPEC
-- . .
-- ....................................................
procedure Delete_Item
(Targeted_B_Plus_Tree : in out B_PLUS_TREE;
Key_Value : in KEY_TYPE;
Non_Key_Information : in NON_KEY_ITEM_TYPE);
--| Purpose
--| Remove an element from the Targeted_B_Plus_Tree.
--|
--| Exceptions
--| Key_Does_Not_Exist_In_This_B_Plus_Tree
--| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree
--|
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Key_Exists . SPEC
-- . .
-- ....................................................
function Key_Exists (Targeted_B_Plus_Tree : in B_PLUS_TREE;
Search_Key : in KEY_TYPE)
return BOOLEAN;
--| Purpose
--| Return TRUE iff Search_Key is found in Targeted_B_Plus_Tree.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Number_Of_Keys_Stored . SPEC
-- . .
-- ....................................................
function Number_Of_Keys_Stored
(Targeted_B_Plus_Tree : in B_PLUS_TREE)
return NATURAL;
--| Purpose
--| Return the Number_of_Keys_Stored in Targeted_B_Plus_Tree.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Get_Item_Container . SPEC
-- . .
-- ....................................................
function Get_Item_Container
(Targeted_B_Plus_Tree : in B_PLUS_TREE;
Search_Key : in KEY_TYPE )
return NON_KEY_ITEM_CONTAINER;
--| Purpose
--| Return the NON_KEY_ITEM_CONTAINER associated with the
--| Search_Key in Targeted_B_Plus_Tree.
--|
--| Exceptions
--| Key_Does_Not_Exist_In_This_B_Plus_Tree
--| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree
--|
--| Notes
--| This procedure involves copying the entire container. If
--| your NON_KEY_ITEM_TYPE is quite large, it may be advisable
--| to implement it as a pointer to the "real" structures,
--| thus reducing the copying burden per instance of the
--| NON_KEY_ITEM_TYPE to that of a single pointer.
-- ....................................................
-- . .
-- . BP_Tree.Get_First_Key . SPEC
-- . .
-- ....................................................
function Get_First_Key (Targeted_B_Plus_Tree : in B_PLUS_TREE)
return KEY_TYPE;
--| Purpose
--| Return the first KEY_TYPE in Targeted_B_Plus_Tree.
--|
--| Exceptions
--| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree
--|
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Get_Last_Key . SPEC
-- . .
-- ....................................................
function Get_Last_Key (Targeted_B_Plus_Tree : in B_PLUS_TREE)
return KEY_TYPE;
--| Purpose
--| Return the last KEY_TYPE in Targeted_B_Plus_Tree.
--|
--| Exceptions
--| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree
--|
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.A_Preceding_Key_Exists . SPEC
-- . .
-- ....................................................
function A_Preceding_Key_Exists
(Targeted_B_Plus_Tree : in B_PLUS_TREE;
Search_Key : in KEY_TYPE)
return Boolean;
--| Purpose
--| Determine if a key exists in the Targeted_B_Plus_Tree
--| before the Search_Key.
--|
--| Exceptions
--| Key_Does_Not_Exist_In_This_B_Plus_Tree
--| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree
--|
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Get_Preceding_Key . SPEC
-- . .
-- ....................................................
function Get_Preceding_Key
(Targeted_B_Plus_Tree : in B_PLUS_TREE;
Search_Key : in KEY_TYPE)
return KEY_TYPE;
--| Purpose
--| Obtain the preceding key in the Targeted_B_Plus_Tree
--| before the Search_Key.
--|
--| Exceptions
--| Key_Does_Not_Exist_In_This_B_Plus_Tree
--| No_Preceding_Key_Exists_In_This_B_Plus_Tree
--| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree
--|
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.A_Following_Key_Exists . SPEC
-- . .
-- ....................................................
function A_Following_Key_Exists
(Targeted_B_Plus_Tree : in B_PLUS_TREE;
Search_Key : in KEY_TYPE)
return Boolean;
--| Purpose
--| Determine if a key exists in the Targeted_B_Plus_Tree after
--| the Search_Key.
--|
--| Exceptions
--| Key_Does_Not_Exist_In_This_B_Plus_Tree
--| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree
--|
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Get_Following_Key . SPEC
-- . .
-- ....................................................
function Get_Following_Key
(Targeted_B_Plus_Tree : in B_PLUS_TREE;
Search_Key : in KEY_TYPE)
return KEY_TYPE;
--| Purpose
--| Obtain the following key in the Targeted_B_Plus_Tree
--| before the Search_Key.
--|
--| Exceptions
--| Key_Does_Not_Exist_In_This_B_Plus_Tree
--| No_Following_Key_Exists_In_This_B_Plus_Tree
--| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree
--|
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Delete_Key . SPEC
-- . .
-- ....................................................
procedure Delete_Key
(Targeted_B_Plus_Tree : in out B_PLUS_TREE;
Search_Key : in KEY_TYPE);
--| Purpose
--| Remove a Search_Key from the Targeted_B_Plus_Tree.
--|
--| Exceptions
--| Key_Does_Not_Exist_In_This_B_Plus_Tree
--| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree
--|
--| Notes
--| The NON_KEY_ITEM_CONTAINER associated with this key will
--| be emptied via the Destroy_Contents procedure.
-- ....................................................
-- . .
-- . BP_Tree.Exchange . SPEC
-- . .
-- ....................................................
procedure Exchange (First_B_Plus_Tree : in out B_PLUS_TREE;
Second_B_Plus_Tree : in out B_PLUS_TREE);
--| Purpose
--| Exchanges the values of First_B_PLUS_TREE and
--| Second_B_PLUS_TREE in O(1) time.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Assign . SPEC
-- . .
-- ....................................................
procedure Assign (To_B_Plus_Tree : in out B_PLUS_TREE;
From_B_Plus_Tree : in B_PLUS_TREE);
--| Purpose
--| Replaces the contents of To_B_Plus_Tree with
--| From_B_Plus_Tree.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Destroy . SPEC
-- . .
-- ....................................................
procedure Destroy (Targeted_B_Plus_Tree : in out B_PLUS_TREE);
--| Purpose
--| Destroys all keys and all associated containers
--| and renders the tree Empty.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . BP_Tree.Destroy . SPEC
-- . .
-- ....................................................
function Empty (Targeted_B_Plus_Tree: in B_PLUS_TREE)
return Boolean;
--| Purpose
--| Determine if Targeted_B_Plus_Tree is empty.
--|
--| Exceptions (none)
--| Notes (none)
private
type B_PLUS_TREE_DESCRIPTOR;
type B_PLUS_TREE is access B_PLUS_TREE_DESCRIPTOR;
end BP_Tree;
--::::::::::
--cisc.spc
--::::::::::
-- *******************************************
-- * *
-- * CASE_INSENSITIVE_STRING_COMPARISON * SPEC
-- * *
-- *******************************************
package Case_Insensitive_String_Comparison is
--| Purpose
--| This package provides a complete set of comparison functions on strings
--| where case is NOT important ("a" = "A").
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Programmer: Michael Gordon
-- .................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.TOUPPER . SPEC
-- . .
-- .................................................
function ToUpper (C: CHARACTER) return CHARACTER;
--| Purpose
--| If C is in 'a'..'z' return the corresponding upper case
--| character. Otherwise, return C. This is implemented by a table
--| lookup for speed.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.UPCASE . SPEC
-- . .
-- .................................................
procedure UpCase (S: in out STRING);
--| Purpose
--| Convert all characters in S to upper case.
--|
--| Exceptions (none)
--| Notes (none)
pragma inline(UpCase);
-- .................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.UPCASE . SPEC
-- . .
-- .................................................
function UpCase (S: STRING) return STRING;
--| Purpose
--| Make a copy of S, convert all lower case characters to upper
--| case and return the copy.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.TOLOWER . SPEC
-- . .
-- .................................................
function ToLower (C: CHARACTER) return CHARACTER;
--| Purpose
--| If C is in 'A'..'Z' return the corresponding lower case
--| character. Otherwise, return C. This is implemented by a table
--| lookup for speed.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.DOWNCASE . SPEC
-- . .
-- .................................................
procedure DownCase (S: in out STRING);
--| Purpose
--| Convert all characters in S to lower case.
--|
--| Exceptions (none)
--| Notes (none)
pragma inline(DownCase);
-- .................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.DOWNCASE . SPEC
-- . .
-- .................................................
function DownCase (S: STRING) return STRING;
--| Purpose
--| Make a copy of S, convert all lower case characters to lower
--| case and return the copy.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.COMPARE . SPEC
-- . .
-- .................................................
function Compare (P, Q: STRING) return INTEGER;
--| Purpose
--| Return an integer less than zero if P < Q, zero if P = Q, and
--| an integer greater than zero if P > Q.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.EQUAL . SPEC
-- . .
-- .................................................
function Equal (P, Q: STRING) return BOOLEAN;
--| Purpose
--| Return TRUE iff P = Q.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.LESS . SPEC
-- . .
-- .................................................
function Less (P, Q: STRING) return BOOLEAN;
--| Purpose
--| Return TRUE iff P < Q.
--|
--| Exceptions (none)
--| Notes (none)
-- ......................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.LESS_OR_EQUAL . SPEC
-- . .
-- ......................................................
function Less_or_Equal (P, Q: STRING) return BOOLEAN;
--| Purpose
--| Return TRUE iff P <= Q.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.GREATER . SPEC
-- . .
-- .................................................
function Greater (P, Q: STRING) return BOOLEAN;
--| Purpose
--| Return TRUE iff P > Q.
--|
--| Exceptions (none)
--| Notes (none)
-- ..........................................................
-- . .
-- . CASE_INSENSITIVE_STRING_COMPARISION.GREATER_OR_EQUAL . SPEC
-- . .
-- ..........................................................
function Greater_or_Equal (P, Q: STRING) return BOOLEAN;
--| Purpose
--| Return TRUE iff P >= Q.
--|
--| Exceptions (none)
--| Notes (none)
private
pragma inline (Equal, Less, Less_or_Equal, Greater, Greater_or_Equal);
pragma inline (ToUpper, ToLower);
end Case_Insensitive_String_Comparison;
--::::::::::
--cli.spc
--::::::::::
-- **************************************
-- * *
-- * CLI (Command Line Interface) * SPEC
-- * *
-- **************************************
package CLI is
--| Purpose
--| CLI is a package which implements a Command
--| Line Interface. It mirrors the UNIX/C
--| command line interface, providing an argument
--| count and the arguments themselves.
--|
--| Initialization Exceptions (none)
--|
--| Notes
--| Compiler limit on string length and dynamic memory.
--| INITIALIZE must be called once, and only once, during
--| the execution of the main Ada proc.
--|
--| Modifications
--| 2/25/88 Richard Conn Initial Version
--| 5/12/89 Richard Conn Review and Upgrade
--| 4/11/90 Richard Conn MIL-HDBK-1804 Annotations and
--| Meridian Ada Interface Added
-- ...................................
-- . .
-- . CLI.INITIALIZE . SPEC
-- . .
-- ...................................
procedure Initialize (Program_Name : in STRING;
Command_Line_Prompt : in STRING);
--| Purpose
--| Initialize this package. This routine must be called
--| before any other routines or objects are called or referenced.
--|
--| Exceptions (none)
--|
--| Notes
--| CALL THIS PROCEDURE ONLY ONE TIME
-- ...................................
-- . .
-- . CLI.ARGC (Argument Count) . SPEC
-- . .
-- ...................................
function ArgC return NATURAL;
--| Purpose
--| Return the number (1 to N) of command line arguments.
--| ARGC is at least 1 because the name of the program or
--| process is always ARGV(0).
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................
-- . .
-- . CLI.ARGV (Argument Value) . SPEC
-- . .
-- ...................................
function ArgV (Index : in NATURAL) return STRING;
--| Purpose
--| Return the INDEXth (0 <= INDEX < ARGC) command line
--| argument. Example: if ARGC = 1, ARGV(0) is the only
--| valid argument string. ARGV(0) is always the name of
--| the program or process.
--|
--| Exceptions
--| INVALID_INDEX raised if Index >= ARGC
--|
--| Notes (none)
INVALID_INDEX : exception;
UNEXPECTED_ERROR : exception; -- raised anytime
end CLI;
--::::::::::
--cset.spc
--::::::::::
-- ******************************************************
-- * *
-- * Character_Set * SPEC
-- * *
-- ******************************************************
package Character_Set is
--| Purpose
--| These routines test for the following subsets of package
--| ASCII:
--| Routine Subset tested for
--| ======= =================
--| ALPHA 'a'..'z' | 'A'..'Z'
--| ALPHA_NUMERIC ALPHA | '0'..'9'
--| CONTROL < ' ' | DEL
--| DIGIT '0'..'9'
--| GRAPHIC ' ' < ch < DEL (does not include space)
--| HEXADECIMAL DIGIT | 'A'..'F' | 'a'..'f'
--| LOWER 'a'..'z'
--| PRINTABLE GRAPHIC | ' '
--| PUNCTUATION GRAPHIC and not ALPHA_NUMERIC
--| SPACE HT | LF | VT | FF | CR | ' '
--| UPPER 'A'..'Z'
--|
--| Initialization Exceptions (none)
--| Notes
--| Most of the "functions" are actually arrays indexed by
--| CHARACTER, so they are remarkably efficient.
--| Not all MIL-HDBK-1804 PDL annotations are
--| used in this package due to its simplicity.
--|
--| Modifications
--| Author: Richard Conn, TI
--| Modified by: Joseph M. Orost, Concurrent Computer Corp
use ASCII;
type BIT_ARRAY is array (CHARACTER) of BOOLEAN;
pragma PACK (BIT_ARRAY);
-- ...................................................
-- . .
-- . Character_Set.Is_Alpha . SPEC
-- . .
-- ...................................................
Is_Alpha : constant BIT_ARRAY :=
BIT_ARRAY'('a' .. 'z' => TRUE,
'A' .. 'Z' => TRUE,
others => FALSE);
-- ...................................................
-- . .
-- . Character_Set.Is_Alpha_Numeric . SPEC
-- . .
-- ...................................................
Is_Alpha_Numeric : constant BIT_ARRAY :=
BIT_ARRAY'('a' .. 'z' => TRUE,
'A' .. 'Z' => TRUE,
'0' .. '9' => TRUE,
others => FALSE );
-- ...................................................
-- . .
-- . Character_Set.Is_Control . SPEC
-- . .
-- ...................................................
Is_Control : constant BIT_ARRAY :=
BIT_ARRAY'(NUL .. US => TRUE,
DEL => TRUE,
others => FALSE);
-- ...................................................
-- . .
-- . Character_Set.Is_Digit . SPEC
-- . .
-- ...................................................
Is_Digit : constant BIT_ARRAY :=
BIT_ARRAY'('0' .. '9' => TRUE,
others => FALSE);
-- ...................................................
-- . .
-- . Character_Set.Is_Graphic . SPEC
-- . .
-- ...................................................
Is_Graphic : constant BIT_ARRAY :=
BIT_ARRAY'('!' .. '~' => TRUE,
others => FALSE);
-- ...................................................
-- . .
-- . Character_Set.Is_Hexadecimal . SPEC
-- . .
-- ...................................................
Is_Hexadecimal : constant BIT_ARRAY :=
BIT_ARRAY'('0' .. '9' => TRUE,
'A' .. 'F' => TRUE,
'a' .. 'f' => TRUE,
others => FALSE );
-- ...................................................
-- . .
-- . Character_Set.Is_Lower . SPEC
-- . .
-- ...................................................
Is_Lower : constant BIT_ARRAY :=
BIT_ARRAY'('a' .. 'z' => TRUE,
others => FALSE);
-- ...................................................
-- . .
-- . Character_Set.Is_Printable . SPEC
-- . .
-- ...................................................
Is_Printable : constant BIT_ARRAY :=
BIT_ARRAY'(' ' .. '~' => TRUE,
others => FALSE);
-- ...................................................
-- . .
-- . Character_Set.Is_Punctuation . SPEC
-- . .
-- ...................................................
Is_Punctuation : constant BIT_ARRAY :=
BIT_ARRAY'('!' .. '/' => TRUE,
':' .. '@' => TRUE,
'[' .. '`' => TRUE,
'{' .. '~' => TRUE,
others => FALSE );
-- ...................................................
-- . .
-- . Character_Set.Is_Space . SPEC
-- . .
-- ...................................................
Is_Space : constant BIT_ARRAY :=
BIT_ARRAY'(HT => TRUE,
LF => TRUE,
VT => TRUE,
FF => TRUE,
CR => TRUE,
' ' => TRUE,
others => FALSE);
-- ...................................................
-- . .
-- . Character_Set.Is_Upper . SPEC
-- . .
-- ...................................................
Is_Upper : constant BIT_ARRAY :=
BIT_ARRAY'('A' .. 'Z' => TRUE,
others => FALSE);
type TRANSLATION_ARRAY is array (CHARACTER) of CHARACTER;
pragma PACK (TRANSLATION_ARRAY);
-- ...................................................
-- . .
-- . Character_Set.Lower . SPEC
-- . .
-- ...................................................
Lower : constant TRANSLATION_ARRAY :=
--| Notes
--| LOWER can be used in place of TO_LOWER (Ada won't
--| allow overloading of an object and a procedure).
(NUL, SOH, STX, ETX, EOT, ENQ, ACK, BEL, BS , HT ,
LF , VT , FF , CR , SO , SI , DLE, DC1, DC2, DC3,
DC4, NAK, SYN, ETB, CAN, EM , SUB, ESC, FS , GS ,
RS , US , ' ', '!', '"', ASCII.SHARP, '$', '%', '&', ''',
'(', ')', '*', '+', ',', '-', '.', '/', '0', '1',
'2', '3', '4', '5', '6', '7', '8', '9', ':', ';',
'<', '=', '>', '?', '@', 'a', 'b', 'c', 'd', 'e',
'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y',
'z', '[', '\', ']', '^', '_', '`', 'a', 'b', 'c',
'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
'x', 'y', 'z', '{', '|', '}', '~', DEL);
-- ...................................................
-- . .
-- . Character_Set.To_Lower . SPEC
-- . .
-- ...................................................
function To_Lower (Ch : in CHARACTER) return CHARACTER;
procedure To_Lower (Ch : in out CHARACTER);
procedure To_Lower (Str : in out STRING);
-- ...................................................
-- . .
-- . Character_Set.Upper . SPEC
-- . .
-- ...................................................
Upper : constant TRANSLATION_ARRAY :=
--| Notes
--| UPPER can be used in place of TO_UPPER.
--|
(NUL, SOH, STX, ETX, EOT, ENQ, ACK, BEL, BS , HT ,
LF , VT , FF , CR , SO , SI , DLE, DC1, DC2, DC3,
DC4, NAK, SYN, ETB, CAN, EM , SUB, ESC, FS , GS ,
RS , US , ' ', '!', '"', ASCII.SHARP, '$', '%', '&', ''',
'(', ')', '*', '+', ',', '-', '.', '/', '0', '1',
'2', '3', '4', '5', '6', '7', '8', '9', ':', ';',
'<', '=', '>', '?', '@', 'A', 'B', 'C', 'D', 'E',
'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
'Z', '[', '\', ']', '^', '_', '`', 'A', 'B', 'C',
'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M',
'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
'X', 'Y', 'Z', '{', '|', '}', '~', DEL);
-- ...................................................
-- . .
-- . Character_Set.To_Upper . SPEC
-- . .
-- ...................................................
function To_Upper (Ch : in CHARACTER) return CHARACTER;
procedure To_Upper (Ch : in out CHARACTER);
procedure To_Upper (Str : in out STRING);
subtype CONTROL_CHARACTER_NAME_2 is STRING (1 .. 2);
subtype CONTROL_CHARACTER_NAME_3 is STRING (1 .. 3);
-- ...................................................
-- . .
-- . Character_Set.CC_Name_2 . SPEC
-- . .
-- ...................................................
function CC_Name_2 (Ch : CHARACTER)
return CONTROL_CHARACTER_NAME_2;
--| Purpose
--| Returns Ch as a two-character string. If Ch is a control
--| character, the string contains a caret (^) followed by
--| the control character letter (e.g., ^H for ASCII.BS).
--| If Ch is not a control character, the string contains a
--| leading space and the character.
-- ...................................................
-- . .
-- . Character_Set.CC_Name_3 . SPEC
-- . .
-- ...................................................
function CC_Name_3 (Ch : CHARACTER)
return CONTROL_CHARACTER_NAME_3;
--| Purpose
--| Returns Ch as a three-character string. If Ch is a control
--| character, the string contains the name given in ASCII (e.g.,
--| "BS " for ^H). If Ch is not a control character, the string
--| contains two leading spaces and the character.
end Character_Set;
--::::::::::
--cssc.spc
--::::::::::
-- ********************************************************
-- * *
-- * Case_Sensitive_String_Comparison * SPEC
-- * *
-- ********************************************************
package Case_Sensitive_String_Comparison is
--| Purpose
--| This package provides a complete set of comparison
--| functions on strings where case is important ("a" /= "A").
--| In most cases these have the same effect as the Ada
--| predefined operators. However, using this package
--| makes it easier to substitute case-insensitive comparison
--| later.
--|
--| Initialization Exceptions (none)
--| Notes
--| No exceptions are raised by any method, so the MIL-HDBK-1804
--| annotation requirements are reduced.
--|
--| Modifications
--| Author: Michael Gordon, Intermetrics
-- ...................................................
-- . .
-- . Case_Sensitive_String_Comparison.Compare . SPEC
-- . .
-- ...................................................
function Compare (P, Q: STRING) return INTEGER;
--| Purpose
--| Return an integer less than zero if P < Q, zero if
--| P = Q, and an integer greater than zero if P > Q.
-- ...................................................
-- . .
-- . Case_Sensitive_String_Comparison.Equal . SPEC
-- . .
-- ...................................................
function Equal (P, Q: STRING) return BOOLEAN;
--| Purpose
--| Return True iff P = Q.
-- ...................................................
-- . .
-- . Case_Sensitive_String_Comparison.Less . SPEC
-- . .
-- ...................................................
function Less (P, Q: STRING) return BOOLEAN;
--| Purpose
--| Return True iff P < Q.
-- ...................................................
-- . .
-- . Case_Sensitive_String_Comparison.Less_or_Equal . SPEC
-- . .
-- ...................................................
function Less_or_Equal (P, Q: STRING) return BOOLEAN;
--| Purpose
--| Return True iff P <= Q.
-- ...................................................
-- . .
-- . Case_Sensitive_String_Comparison.Greater . SPEC
-- . .
-- ...................................................
function Greater (P, Q: STRING) return BOOLEAN;
--| Purpose
--| Return True iff P > Q.
-- ......................................................
-- . .
-- . Case_Sensitive_String_Comparison.Greater_or_Equal . SPEC
-- . .
-- ......................................................
function Greater_or_Equal (P, Q: STRING) return BOOLEAN;
--| Purpose
--| Return True iff P >= Q.
private
pragma Inline (equal, less, less_or_equal, greater,
greater_or_equal);
end Case_Sensitive_String_Comparison;
--::::::::::
--cstrings.spc
--::::::::::
-- *********************************************************
-- * *
-- * CStrings * SPEC
-- * *
-- *********************************************************
generic
Max_String_Length : NATURAL := 400; -- max length of a string
-- including the trailing
-- ASCII.NUL character
package CStrings is
--| Purpose
--| CStrings provides a number of procedures and functions
--| which manipulate null-terminated strings (called C Strings)
--| and Ada strings (which contain no null character).
--| Type STRING is used to contain the C and Ada strings.
--| A C string contains a sequence of characters followed
--| by an ASCII.NUL; more characters may follow the ASCII.NUL
--| in the buffer, but they are ignored. An Ada string is
--| a sequence of characters bound by the dimensions of the
--| buffer; all characters in the buffer are a part of the
--| string.
--| The names of these procedures and functions were taken
--| from a listing of string-oriented C library functions.
--| The functionality of these routines is almost always
--| identical to the functionality of the original C routines.
--|
--| Initialization Exceptions (none)
--| Notes
--| Reference Sun Release 4.0 man pages on "strings".
--| Each string referenced in this specification is followed
--| by one of the following comments:
--|
--| Comment Meaning
--| =========== =========================================
--| -- Ada The string is an Ada String
--| -- C The string is a C String
--| -- Ada or C The string is an Ada String or a C String
--|
--| Modifications Author: Richard Conn, MACA
--| 2/27/90 Richard Conn Initial Version and Release
type COMPARISON_RESULT is (LESS_THAN, EQUAL_TO, GREATER_THAN);
-- Exceptions
LENGTH_ERROR : exception; -- resulting string length
-- is too long for buffer
-- ...................................................
-- . .
-- . CStrings.Make_Cstring . SPEC
-- . .
-- ...................................................
procedure Make_Cstring (From : in STRING; -- Ada or C
To : out STRING); -- C
--| Purpose
--| Place a copy of From into To. Place
--| the null terminator (ASCII.NUL) at the character
--| in To corresponding to From(From'LAST+1).
--|
--| Exceptions
--| LENGTH_ERROR -- Destination is too short to hold
--| the result or the result exceeds
--| Max_String_Length characters
-- ...................................................
-- . .
-- . CStrings.Make_Cstring . SPEC
-- . .
-- ...................................................
procedure Make_Cstring (From_To : in out STRING; -- Ada or C
Index : in NATURAL);
--| Purpose
--| Place a null into From_To on the indicated
--| character.
--|
--| Exceptions
--| LENGTH_ERROR -- Index is out of bounds
-- ...................................................
-- . .
-- . CStrings.Ada_String . SPEC
-- . .
-- ...................................................
function Ada_String (From : in STRING) -- Ada or C
return STRING; -- Ada
--| Purpose
--| Return the slice of From up to but not including
--| the ending NUL. If From is an Ada string (no null),
--| then the entire string is returned.
--|
--| Exceptions (none)
-- ...................................................
-- . .
-- . CStrings.Strcat . SPEC
-- . .
-- ...................................................
procedure Strcat (To : in out STRING; -- C
From : in STRING); -- Ada or C
function Strcat (From_Part_1 : in STRING; -- Ada or C
From_Part_2 : in STRING) -- Ada or C
return STRING; -- C
--| Purpose
--| Strcat appends a copy of string Source to the end
--| of string Destination. The procedure Strcat modifies
--| the string Destination, while the function Strcat
--| does not modify the string Destination.
--|
--| Exceptions
--| LENGTH_ERROR -- Destination is too short to hold
--| the result or the result exceeds
--| Max_String_Length characters
-- ...................................................
-- . .
-- . CStrings.Strncat . SPEC
-- . .
-- ...................................................
procedure Strncat (To : in out STRING; -- C
From : in STRING; -- Ada or C
Length : in NATURAL);
function Strncat (To : in STRING; -- Ada or C
From : in STRING; -- Ada or C
Length : in NATURAL)
return STRING; -- C
--| Purpose
--| Strncat appends a copy of string From to the end
--| of string To. The procedure Strncat modifies
--| the string To, while the function Strncat
--| does not modify the string To. At most Length
--| characters are appended.
--|
--| Exceptions
--| LENGTH_ERROR -- Destination is too short to hold
--| the result or the result exceeds
--| Max_String_Length characters
-- ...................................................
-- . .
-- . CStrings.Strcmp . SPEC
-- . .
-- ...................................................
function Strcmp (String1 : in STRING; -- Ada or C
String2 : in STRING) -- Ada or C
return COMPARISON_RESULT;
--| Purpose
--| Strcmp compares its arguments and returns the values
--| LESS_THAN, EQUAL_TO, or GREATER_THAN accordingly as
--| String1 is lexicographically less than, equal to, or
--| greater than String2.
--|
--| Exceptions (none)
-- ...................................................
-- . .
-- . CStrings.Strncmp . SPEC
-- . .
-- ...................................................
function Strncmp (String1 : in STRING; -- Ada or C
String2 : in STRING; -- Ada or C
Length : in NATURAL)
return COMPARISON_RESULT;
--| Purpose
--| Strncmp compares its arguments and returns the values
--| LESS_THAN, EQUAL_TO, or GREATER_THAN accordingly as
--| String1 is lexicographically less than, equal to, or
--| greater than String2. Strncmp compares at most
--| Length characters.
--|
--| Exceptions (none)
-- ...................................................
-- . .
-- . CStrings.Strcasecmp . SPEC
-- . .
-- ...................................................
function Strcasecmp (String1 : in STRING; -- Ada or C
String2 : in STRING) -- Ada or C
return COMPARISON_RESULT;
--| Purpose
--| Strcasecmp compares its arguments and returns the values
--| LESS_THAN, EQUAL_TO, or GREATER_THAN accordingly as
--| String1 is lexicographically less than, equal to, or
--| greater than String2. Differences in case are ignored.
--|
--| Exceptions (none)
-- ...................................................
-- . .
-- . CStrings.Strncasecmp . SPEC
-- . .
-- ...................................................
function Strncasecmp (String1 : in STRING; -- Ada or C
String2 : in STRING; -- Ada or C
Length : in NATURAL)
return COMPARISON_RESULT;
--| Purpose
--| Strncasecmp compares its arguments and returns the values
--| LESS_THAN, EQUAL_TO, or GREATER_THAN accordingly as
--| String1 is lexicographically less than, equal to, or
--| greater than String2. Differences in case are ignored.
--| At most Length characters are compared.
--|
--| Exceptions (none)
-- ...................................................
-- . .
-- . CStrings.Strcpy . SPEC
-- . .
-- ...................................................
procedure Strcpy (From : in STRING; -- Ada or C
To : out STRING); -- C
--| Purpose
--| Strcpy copies From to To, stopping after
--| the null character has been copied.
--|
--| Exceptions
--| LENGTH_ERROR -- Destination is too short to hold
--| the result
-- ...................................................
-- . .
-- . CStrings.Strncpy . SPEC
-- . .
-- ...................................................
procedure Strncpy (From : in STRING; -- Ada or C
To : out STRING; -- C
Length : in NATURAL);
--| Purpose
--| Strncpy copies From to To, copying
--| at most Length characters. If there are more
--| than Length characters in To, Length
--| characters will be copied and a trailing null
--| appended after the last character.
--|
--| Exceptions
--| LENGTH_ERROR -- Destination is too short to hold
--| the result
-- ...................................................
-- . .
-- . CStrings.Strlen . SPEC
-- . .
-- ...................................................
function Strlen (String1 : in STRING) -- Ada or C
return NATURAL;
pragma inline (Strlen);
--| Purpose
--| Strlen returns the number of characters in String1,
--| not including the null-terminating character.
--|
--| Exceptions (none)
-- ...................................................
-- . .
-- . CStrings.Strchr . SPEC
-- . .
-- ...................................................
function Strchr (String1 : in STRING; -- Ada or C
Char1 : in CHARACTER)
return NATURAL;
--| Purpose
--| Strchr returns the index of the first occurrence
--| of Char1 in the string String1 or the value 0 if
--| Char1 does not occur in String1. The null-terminating
--| character is considered to be part of String1.
--|
--| Exceptions (none)
--|
--| Notes
--| This function is identical to the index and strchr
--| functions in C.
-- ...................................................
-- . .
-- . CStrings.Strrchr . SPEC
-- . .
-- ...................................................
function Strrchr (String1 : in STRING; -- Ada or C
Char1 : in CHARACTER)
return NATURAL;
--| Purpose
--| Strrchr returns the index of the last occurrence
--| of Char1 in the string String1 or the value 0 if
--| Char1 does not occur in String1. The null-terminating
--| character is considered to be part of String1.
--|
--| Exceptions (none)
--|
--| Notes
--| This function is identical to the rindex and strrchr
--| functions in C.
-- ...................................................
-- . .
-- . CStrings.Strpbrk . SPEC
-- . .
-- ...................................................
function Strpbrk (String1 : in STRING; -- Ada or C
String2 : in STRING) -- Ada or C
return NATURAL;
--| Purpose
--| Strpbrk returns the index of the first occurrence in
--| String1 of any character from String2 or the value 0 if
--| no character from String2 exists in String1.
--|
--| Exceptions (none)
-- ...................................................
-- . .
-- . CStrings.Strspn . SPEC
-- . .
-- ...................................................
function Strspn (String1 : in STRING; -- Ada or C
String2 : in STRING) -- Ada or C
return NATURAL;
--| Purpose
--| Strspn returns the length of the initial segment
--| of String1 which consists entirely of characters
--| from String2.
--|
--| Exceptions (none)
-- ...................................................
-- . .
-- . CStrings.Strcspn . SPEC
-- . .
-- ...................................................
function Strcspn (String1 : in STRING; -- Ada or C
String2 : in STRING) -- Ada or C
return NATURAL;
--| Purpose
--| Strcspn returns the length of the initial segment
--| of String1 which consists entirely of characters
--| not from String2.
--|
--| Exceptions (none)
-- ...................................................
-- . .
-- . CStrings.Strtok . SPEC
-- . .
-- ...................................................
procedure Strtok (Target : in STRING; -- Ada or C
Start : in out NATURAL;
Delimiters : in STRING; -- Ada or C
Next_Token : out STRING); -- C
--| Purpose
--| Strtok considers the string Target to consist of a
--| sequence of zero or more text tokens separated by spans
--| of one or more characters from the separator string
--| Delimiters. A call to Strtok returns the first token
--| in Target on or after the character indexed by Start.
--| This token is returned in the string Next_Token with
--| a null character immediately following the token.
--| The separator string Delimiters may be different from
--| call to call.
--|
--| Strtok must be called with Start's actual parameter
--| being an initialized variable; generally, Start's
--| initial value is Target'FIRST.
--|
--| Exceptions
--| LENGTH_ERROR -- Next_Token is too short to hold
--| the result
end CStrings;
--::::::::::
--darray.spc
--::::::::::
-- **************************************************
-- * *
-- * DARRAY_PKG * SPEC
-- * *
-- **************************************************
generic
type ELEM_TYPE is private;
with function Equal (E1, E2: ELEM_TYPE)
return BOOLEAN is "=";
package Darray_Pkg is
--| Purpose
--| This package provides the dynamic array (darray) abstract data type.
--| A darray has completely dynamic bounds, which change during runtime as
--| elements are added to/removed from the top/bottom. darrays are similar
--| to deques, differing only in that operations for indexing into the
--| structure are also provided. A darray is indexed by integers that
--| fall within the current bounds. The component type, elem_type, of a
--| darray is a generic formal parameter of this package, along with a
--| function, equal, that is assumed to form an equality relation over
--| over elem_type.
--|
--| The notation, <first, elts>, will be used to denote a darray.
--| first is the current low bound of the darray. elts is the sequence
--| of elements contained in the darray. For a given darray, d, the
--| dot selection mechanism is used to refer to these components, e.g.,
--| d.first and d.elts. & is used for sequence concatenation, and also
--| for prepending/postpending a single element to a sequence. |s| is
--| the number of elements in a sequence, s, and () is the null sequence.
--| Standard Ada array indexing notation is adopted for sequences.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Programmer: Ron Kownacki, Intermetrics
-- Primary Types
type DARRAY is private;
type ARRAY_TYPE is array (INTEGER range <>) of ELEM_TYPE;
-- Storage Management Constants and Types (see create procedure)
Default_Predict : constant POSITIVE := 100;
Default_High : constant POSITIVE := 50;
Default_Expand : constant POSITIVE := 100;
-- Exceptions
No_More : exception; -- Raised on incorrect use of an iterator.
Out_of_Bounds : exception; -- Raised on index out of current bounds.
Uninitialized_Darray : exception;
-- Raised on use of uninitialized darray by most operations.
-- Iterators
type ELEMENTS_ITER is private;
-- Constructors
-- ...................................................
-- . .
-- . DARRAY_PKG.CREATE . SPEC
-- . .
-- ...................................................
procedure Create(First: in INTEGER := 1;
Predict: in POSITIVE := Default_Predict;
High_Percent: in POSITIVE := Default_High;
Expand_Percent: in POSITIVE := Default_Expand;
D: in out DARRAY);
--| Purpose
--| Sets d to <first, ()>. If d has previously been initialized,
--| then a destroy(d) is first performed. The predict parameter
--| specifies the initial space allocated. (predict = #elements).
--| The high_percent parameter is the caller's expectation of the
--| percentage of add_highs, out of total adds, to the darray. For
--| example, a caller would specify 100 if it was known that no
--| add_lows would be performed. The expand_percent parameter
--| specifies the amount of additional space, as a percentage of
--| currently allocated space, that is to be allocated whenever an
--| expansion becomes necessary. For example, 100 doubles the
--| allocated space.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.ARRAY_TO_DARRAY . SPEC
-- . .
-- ...................................................
procedure Array_to_Darray(A: in ARRAY_TYPE;
First: in INTEGER := 1;
Predict: in POSITIVE;
High_Percent: in POSITIVE
:= Default_High;
Expand_Percent: in POSITIVE
:= Default_Expand;
D: in out DARRAY);
--| Purpose
--| Sets d to <first, a(a'first..a'last)>. If d has previously
--| been initialized, then an implicit destroy(d) is performed.
--| The high_percent and expand_percent parameters are defined
--| as for create. Raises out_of_bounds iff predict < a'length.
--|
--| Exceptions
--| out_of_bounds
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.SET_FIRST . SPEC
-- . .
-- ...................................................
procedure Set_First(D: in out DARRAY;
First: in INTEGER);
--| Purpose
--| Sets d.first to first.
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.ADD_LOW . SPEC
-- . .
-- ...................................................
procedure Add_Low (D: in out DARRAY;
E: in ELEM_TYPE);
--| Purpose
--| Sets d to <d.first - 1, e & d.elts>.
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.ADD_HIGH . SPEC
-- . .
-- ...................................................
procedure Add_High (D: in out DARRAY;
E: in ELEM_TYPE);
--| Purpose
--| Sets d.elts to d.elts & e.
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.REMOVE_LOW . SPEC
-- . .
-- ...................................................
procedure Remove_Low (D: in out DARRAY);
--| Purpose
--| Sets d to <d.first + 1, d.elts(d.first + 1 .. last(d))>.
--| Raises out_of_bounds iff is_empty(d).
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--| out_of_bounds
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.REMOVE_HIGH . SPEC
-- . .
-- ...................................................
procedure Remove_High (D: in out DARRAY);
--| Purpose
--| Sets d.elts to d.elts(d.first..last(d) - 1).
--| Raises out_of_bounds iff is_empty(d).
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--| out_of_bounds
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.STORE . SPEC
-- . .
-- ...................................................
procedure Store (D: in out DARRAY;
I: in INTEGER;
E: in ELEM_TYPE);
--| Purpose
--| Replaces d.elts(i) with e. Raises out_of_bounds iff
--| either is_empty(d) or i is not in d.first..last(d).
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--| out_of_bounds
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.COPY . SPEC
-- . .
-- ...................................................
function Copy (D: DARRAY) return DARRAY;
--| Purpose
--| Returns a copy of d. Subsequent changes to the structure of d
--| will not be visible through the application of operations to
--| the copy of d, and vice versa. Assignment or parameter passing
--| without using copy (or copy_deep, described below) will result
--| in a single darray value being shared among objects.
--| Raises uninitialized_darray if d has not been initialized.
--| The assignment operation is used to transfer the values of
--| the elem_type component objects of d; consequently, changes
--| in these values may be observable through both darrays if
--| elem_type is an access type, or contains access type
--| components.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.COPY_DEEP . SPEC
-- . .
-- ...................................................
generic
with function Copy (E: ELEM_TYPE) return ELEM_TYPE;
function Copy_Deep (D: DARRAY) return DARRAY;
--| Purpose
--| Returns a copy of d. Subsequent changes to the structure of d
--| will not be visible through the application of operations to
--| the copy of d, and vice versa. Assignment or parameter passing
--| without using copy_deep or copy will result in a single
--| darray value being shared among objects.
--| Raises uninitialized_darray if d has not been initialized.
--| The transfer of elem_type component objects is accomplished by
--| using the assignment operation in conjunction with the copy
--| function. Consequently, the user can prevent sharing of
--| elem_type access components.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- Query Operations
-- ...................................................
-- . .
-- . DARRAY_PKG.FETCH . SPEC
-- . .
-- ...................................................
function Fetch (D: DARRAY; I: INTEGER) return ELEM_TYPE;
--| Purpose
--| Returns d.elts(i). Raises out_of_bounds iff either is_empty(d)
--| or i is not in d.first..last(d).
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| out_of_bounds
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.LOW . SPEC
-- . .
-- ...................................................
function Low (D: in DARRAY) return ELEM_TYPE;
--| Purpose
--| Returns d.elts(d.first). Raises out_of_bounds iff is_empty(d).
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| out_of_bounds
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.HIGH . SPEC
-- . .
-- ...................................................
function High (D: in DARRAY) return ELEM_TYPE;
--| Purpose
--| Returns d.elts(last(d)). Raises out_of_bounds iff is_empty(d).
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| out_of_bounds
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.FIRST . SPEC
-- . .
-- ...................................................
function First (D: in DARRAY) return INTEGER;
--| Purpose
--| Returns d.first.
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.LAST . SPEC
-- . .
-- ...................................................
function Last (D: in DARRAY) return INTEGER;
--| Purpose
--| Returns d.first + |d.elts| - 1.
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.IS_EMPTY . SPEC
-- . .
-- ...................................................
function Is_Empty (D: in DARRAY) return BOOLEAN;
--| Purpose
--| Returns length(d) = 0, or equivalently, last(d) < d.first.
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.LENGTH . SPEC
-- . .
-- ...................................................
function Length (D: in DARRAY) return NATURAL;
--| Purpose
--| Returns |d.elts|.
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.EQUAL . SPEC
-- . .
-- ...................................................
function Equal (D1, D2: DARRAY) return BOOLEAN;
--| Purpose
--| Return (d1.first = d2.first and
--| last(d1) = last(d2) and
--| for each i in d1.first..last(d1),
--| equal(d1.elts(i), d2.elts(i)).
--| Raises uninitialized_darray if either d1 or d2 has not been
--| initialized. Note that (d1 = d2) implies that equal(d1, d2)
--| will always hold. "=" is object equality, equal is state
--| equality.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.DARRAY_TO_DARRAY . SPEC
-- . .
-- ...................................................
function Darray_to_Array (D: DARRAY) return ARRAY_TYPE;
--| Purpose
--| Let bounds_range be d.first..d.first + length(d) - 1. If
--| bounds_range is empty, then return an empty array with bounds
--| of 1..0. Otherwise, return bounds_range'(d.elts).
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- Iterators
-- ...................................................
-- . .
-- . DARRAY_PKG.MAKE_ELEMENTS_ITER . SPEC
-- . .
-- ...................................................
function Make_Elements_Iter (D: DARRAY) return ELEMENTS_ITER;
--| Purpose
--| Create and return an elements itererator based on d. This
--| object can then be used in conjunction with the more function
--| and the next procedure to iterate over the components of d.
--| Raises uninitialized_darray if d has not been initialized.
--|
--| Exceptions
--| uninitialized_darray
--|
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.MORE . SPEC
-- . .
-- ...................................................
function More (Iter: ELEMENTS_ITER) return BOOLEAN;
--| Purpose
--| Return true iff the elements iterator has not been exhausted.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . DARRAY_PKG.NEXT . SPEC
-- . .
-- ...................................................
procedure Next (Iter: in out ELEMENTS_ITER;
E: out ELEM_TYPE);
--| Purpose
--| Let iter be based on the darray, d. Successive calls of next
--| will return, in e, successive elements of d.elts. Each call
--| updates the state of the elements iterator. After all elements
--| have been returned, an invocation of next will raise no_more.
--| Requires:
--| d must not be changed between the invocations of
--| make_elements_iterator(d) and next.
--|
--| Exceptions
--| no_more
--|
--| Notes (none)
-- Heap Management
-- ...................................................
-- . .
-- . DARRAY_PKG.DESTROY . SPEC
-- . .
-- ...................................................
procedure Destroy (D: in out DARRAY);
--| Purpose
--| Return space consumed by the darray value associated with object
--| d to the heap. (If d is uninitialized, this operation does
--| nothing.) If other objects share the same darray value, then
--| further use of these objects is erroneous. Components of type
--| elem_type, if they are access types, are not garbage collected.
--| It is the user's responsibility to dispose of these objects.
--| d is left in the uninitialized state.
--|
--| Exceptions (none)
--| Notes (none)
private
type ARRAY_PTR is access ARRAY_TYPE;
type DARRAY_INFO is
record
First_Idx : POSITIVE;
Last_Idx : NATURAL;
First : INTEGER;
High_Percent : POSITIVE;
Expand_Percent : POSITIVE;
Arr : ARRAY_PTR := null;
end record;
type DARRAY is access DARRAY_INFO;
-- Let r be an instance of the representation type.
-- Representation Invariants:
-- 1. r /= null, r.arr /= null (must be initialized to be valid.)
-- 2. r.arr'first = 1 and
-- r.arr'last >= 1
-- 3. r.first_idx <= r.last_idx or
-- r.first_idx = r.last_idx + 1
-- 4. r.first_idx <= r.last_idx =>
-- r.first_idx, r.last_idx in r.arr'range
-- 5. r.expand_percent, r.high_percent get values at creation time,
-- and these never change.
--
-- Abstraction Function: (denoted by A(r))
-- if r.last_idx < r.first_idx then
-- <r.first, ()>
-- else
-- <r.first, (r.arr(r.first_idx),...,r.arr(r.last_idx))>
--
-- These properties follow:
-- 1. length(A(r)) = r.last_idx - r.first_idx + 1
-- 2. last(A(r)) = r.first + r.last_idx - r.first_idx
-- 3. fetch(A(r), i) =
-- if (i - r.first + r.first_idx) in r.first_idx..r.last_idx
-- then r.arr(i - r.first + r.first_idx)
-- else undefined. (out_of_bounds)
type ELEMENTS_ITER is
record
Last : INTEGER := 0;
Current : INTEGER := 1;
Arr : ARRAY_PTR;
end record;
-- Let d be the darray that an elements_iter, i, is based on.
-- Initially, i.current = d.first_idx, i.last = d.last_idx, and
-- i.arr = d.arr.
-- more(i) = i.current <= i.last.
-- next(i) = i.arr(current). i.current incremented by next.
-- Note that if an elements_iter object is not initialized, then
-- more is false.
end Darray_Pkg;
--::::::::::
--dlist.spc
--::::::::::
-- *****************************************************************
-- * *
-- * DOUBLY_LINKED_LIST * SPEC
-- * *
-- *****************************************************************
generic
type ELEMENT_OBJECT is private;
package Doubly_Linked_List is
--| Purpose
--| DOUBLY_LINKED_LIST manipulates the abstract data type
--| LIST_ID, which is a linked list of objects.
--| DOUBLE_LIST provides routines to add objects to,
--| delete objects from, and extract objects from
--| the list. DOUBLE_LIST also allows the user to
--| move about through the list and manipulate the
--| list in various ways.
--|
--| Initialization Exceptions (none)
--|
--| Notes
--| The number of list elements is restricted to
--| INTEGER'LAST and the amount of memory or virtual
--| memory in the computer system.
--|
--| Modifications
--| Author: Richard Conn
-- Types
type ELEMENT_POSITION is new INTEGER range 0 .. INTEGER'LAST;
type LIST_ID is limited private;
-- Exceptions
ADVANCE_PAST_END_OF_LIST : exception;
BACKUP_BEFORE_BEGINNING_OF_LIST : exception;
DYNAMIC_MEMORY_ALLOCATION_PROBLEM : exception;
LIST_IS_EMPTY : exception;
INVALID_INDEX : exception;
UNEXPECTED_ERROR : exception; -- raised anytime
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.INITIALIZE . SPEC
-- . .
-- .............................................................
procedure Initialize (ID : in out LIST_ID);
--| Purpose
--| Initialize the list to empty (the list is empty when
--| first used); if the list contained any elements, they
--| are deleted.
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.FIRST_ELEMENT . SPEC
-- . .
-- .............................................................
function First_Element (ID : in LIST_ID) return ELEMENT_OBJECT;
--| Purpose
--| Return the first element of the list.
--|
--| Exceptions
--| LIST_IS_EMPTY
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.LAST_ELEMENT . SPEC
-- . .
-- .............................................................
function Last_Element (ID : in LIST_ID) return ELEMENT_OBJECT;
--| Purpose
--| Return the last element of the list.
--|
--| Exceptions
--| LIST_IS_EMPTY
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.CURRENT_ELEMENT . SPEC
-- . .
-- .............................................................
function Current_Element (ID : in LIST_ID) return ELEMENT_OBJECT;
--| Purpose
--| Return the current element of the list.
--|
--| Exceptions
--| LIST_IS_EMPTY
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.GOTO_FIRST . SPEC
-- . .
-- .............................................................
procedure Goto_First (ID : in out LIST_ID);
--| Purpose
--| Set the current element of the list to be the first
--| element.
--|
--| Exceptions
--| LIST_IS_EMPTY
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.GOTO_LAST . SPEC
-- . .
-- .............................................................
procedure Goto_Last (ID : in out LIST_ID);
--| Purpose
--| Set the current element of the list to be the last
--| element.
--|
--| Exceptions
--| LIST_IS_EMPTY
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.GOTO_ELEMENT . SPEC
-- . .
-- .............................................................
procedure Goto_Element (ID : in out LIST_ID;
Index : in ELEMENT_POSITION);
--| Purpose
--| Set the current element of the list to be the Nth (INDEX)
--| element.
--|
--| Exceptions
--| INVALID_INDEX
--| LIST_IS_EMPTY
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.CURRENT_INDEX . SPEC
-- . .
-- .............................................................
function Current_Index (ID : in LIST_ID) return ELEMENT_POSITION;
--| Purpose
--| Return the number of the current element.
--|
--| Exceptions
--| LIST_IS_EMPTY
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.LAST_INDEX . SPEC
-- . .
-- .............................................................
function Last_Index (ID : in LIST_ID) return ELEMENT_POSITION;
--| Purpose
--| Return the number of the last element.
--|
--| Exceptions
--| LIST_IS_EMPTY
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.ADVANCE . SPEC
-- . .
-- .............................................................
procedure Advance (ID : in out LIST_ID);
--| Purpose
--| Advance, setting the current element to be the next
--| element.
--|
--| Exceptions
--| ADVANCE_PAST_END_OF_LIST
--| LIST_IS_EMPTY
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.BACKUP . SPEC
-- . .
-- .............................................................
procedure Backup (ID : in out LIST_ID);
--| Purpose
--| Backup, setting the current element to be the previous
--| element.
--|
--| Exceptions
--| BACKUP_BEFORE_BEGINNING_OF_LIST
--| LIST_IS_EMPTY
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.IS_EMPTY . SPEC
-- . .
-- .............................................................
function Is_Empty (ID : in LIST_ID) return BOOLEAN;
--| Purpose
--| Return TRUE if the list is empty.
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.IS_END . SPEC
-- . .
-- .............................................................
function Is_End (ID : in LIST_ID) return BOOLEAN;
--| Purpose
--| Return TRUE if the end of the list has been passed.
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.IS_FIRST . SPEC
-- . .
-- .............................................................
function Is_First (ID : in LIST_ID) return BOOLEAN;
--| Purpose
--| Return TRUE if the current element is the first element.
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.APPEND_ELEMENT . SPEC
-- . .
-- .............................................................
procedure Append_Element (ID : in out LIST_ID;
Element : ELEMENT_OBJECT);
--| Purpose
--| Append an element after the current element; set the current
--| element to this new element.
--|
--| Exceptions
--| DYNAMIC_MEMORY_ALLOCATION_PROBLEM
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.INSERT_ELEMENT . SPEC
-- . .
-- .............................................................
procedure Insert_Element (ID : in out LIST_ID;
Element : ELEMENT_OBJECT);
--| Purpose
--| Insert an element before the current element; the current
--| element remains unchanged.
--|
--| Exceptions
--| DYNAMIC_MEMORY_ALLOCATION_PROBLEM
--|
--| Notes (none)
-- .............................................................
-- . .
-- . DOUBLY_LINKED_LIST.DELETE_ELEMENT . SPEC
-- . .
-- .............................................................
procedure Delete_Element (ID : in out LIST_ID);
--| Purpose
--| Delete the current element; the current element becomes the
--| element following the current element.
--|
--| Exceptions
--| ADVANCE_PAST_END_OF_LIST
--| LIST_IS_EMPTY
--|
--| Notes (none)
private
type ELEMENT;
type ELEMENT_POINTER is access ELEMENT;
type ELEMENT is
record
Content : ELEMENT_OBJECT;
Next : ELEMENT_POINTER;
Previous : ELEMENT_POINTER;
end record;
type LIST_ID is
record
First : ELEMENT_POINTER := null; -- first element
Last : ELEMENT_POINTER := null; -- last element
Current : ELEMENT_POINTER := null; -- current element
Free : ELEMENT_POINTER := null; -- free element list
Number_of_Elements : ELEMENT_POSITION := 0; -- number of elements
Current_Index : ELEMENT_POSITION := 0; -- index of current element
end record;
end Doubly_Linked_List;
--::::::::::
--dyn.spc
--::::::::::
-- *******************************************************
-- * *
-- * DYN * SPEC
-- * *
-- *******************************************************
package Dyn is
--| Purpose
--| Implement a dynamic string object class and provide operations
--| to manipulate objects of this class.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| This is a package of several string manipulation functions based on
--| a built-in dynamic STRING type DYN_STRING. It is an adaptation and
--| extension of the package proposed by Sylvan Rubin of Ford Aerospace and
--| Communications Corporation in the Nov/Dec 1984 issue of the Journal of
--| Pascal, Ada and Modula-2. Some new functions have been added, and much
--| of the body code has been rewritten.
--|
--| This package is derived from DSTR3.SRC in the Ada Software Repository
--| DSTR3.SRC was written by R.G. Cleaveland. The derivation, done by
--| Richard Conn, was done to remove those general-purpose features of the
--| package not needed for the PTF project.
Max_D_String_Length : constant POSITIVE := 100;
-- This is the maximum LENGTH of a dynamic string implemented with this
-- package. This value is "arbitrary" in that any reasonable number
-- equal to or less than the maximum STRING LENGTH permitted by the
-- compiler is acceptable. The specific value above was chosen as a
-- compromise between programmer convenience and memory space requirements.
subtype DS_POS is INTEGER range 0..MAX_D_STRING_LENGTH;
type DYN_STRING is private;
STRING_TOO_SHORT: exception;
-- ..................................................
-- . .
-- . DYN.D_STRING . SPEC
-- . .
-- ..................................................
function D_String (Char: CHARACTER) return DYN_STRING;
--| Purpose
--| Creates a one-byte dynamic string of contents CHAR.
--|
--| Exceptions (none)
--| Notes (none)
-- ..................................................
-- . .
-- . DYN.D_STRING . SPEC
-- . .
-- ..................................................
function D_String (Str : STRING) return DYN_STRING;
--| Purpose
--| Creates a dynamic string of contents STR.
--|
--| Exceptions (none)
--| Notes (none)
-- ..................................................
-- . .
-- . DYN.CHAR . SPEC
-- . .
-- ..................................................
function Char (Dstr : DYN_STRING;
Posit : POSITIVE := 1) return CHARACTER;
--| Purpose
--| Return the Nth character of a dynamic string.
--|
--| Exceptions
--| STRING_TOO_SHORT
--|
--| Notes (none)
-- ..................................................
-- . .
-- . DYN.STR . SPEC
-- . .
-- ..................................................
function Str (Dstr: DYN_STRING) return STRING;
--| Purpose
--| Return the string whose contents is the value of a dynamic
--| string.
--|
--| Exceptions (none)
--| Notes (none)
-- ..................................................
-- . .
-- . DYN.LENGTH . SPEC
-- . .
-- ..................................................
function Length (Dstr: DYN_STRING) return NATURAL;
--| Purpose
--| Returns the LENGTH of the dynamic string.
--|
--| Exceptions (none)
--| Notes (none)
-- ..................................................
-- . .
-- . DYN.CLEAR . SPEC
-- . .
-- ..................................................
procedure Clear (Dstr: in out DYN_STRING);
--| Purpose
--| Makes DSTR a null string.
--|
--| Exceptions (none)
--| Notes (none)
private
type DYN_STRING is
record
Size : INTEGER range 0..MAX_D_STRING_LENGTH;
Data : STRING(1..MAX_D_STRING_LENGTH);
end record;
end Dyn;
--::::::::::
--fof.spc
--::::::::::
-- **********************************
-- * *
-- * Formatted_Output_File (FOF) * SPEC
-- * *
-- **********************************
package Formatted_Output_File is
--| Purpose
--| Formatted_Output_File manipulates objects of type STRING (text),
--| placing text into the output file as it is received.
--| Formatted_Output_File is also used to define the format of the
--| text (number of lines per page, header, footer, etc.).
--|
--| Formatted_Output_File is a form of Report Generator. Taking in
--| raw text and other directives (implemented by its procedures),
--| Formatted_Output_File creates reports (with header lines, footer
--| lines, page numbering, etc).
--|
--| Formatted_Output_File is also referred to as FOF.
--|
--| See the test programs for examples of the use of FOF.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| 04/22/90 Rick Conn Initial version from PTF's FOF
--| package of 8/16/89
type FILE is
private;
Maximum_Number_Of_Lines_On_Page
: constant
:= 200;
Maximum_Line_Length
: constant
:= 200;
Maximum_Number_Of_Header_Footer_Lines
: constant
:= 8;
Maximum_Number_Of_Pages
: constant
:= 32000;
type PAGE_ATTRIBUTE is
( TOP_MARGIN, -- Number of lines before first header
BOTTOM_MARGIN, -- Number of lines after last footer
LEFT_MARGIN, -- Column num of the last col before the 1st char
RIGHT_MARGIN, -- Column number of the last char of the line
LEFT_INDENT, -- Number of columns to indent from LEFT_MARGIN
RIGHT_INDENT, -- Number of columns to indent from RIGHT_MARGIN
TOTAL_LINES, -- Number of lines on a page
HEADER_LINES, -- Number of lines in the header
FOOTER_LINES, -- Number of lines in the footer
LINE_SPACING, -- Number of blank lines after each text line
PAGE_OFFSET, -- Number of columns to offset each line
TEMP_INDENT -- Number of columns to indent next line only
-- (this is an absolute value, not influenced
-- by the LEFT_MARGIN or LEFT_INDENT settings)
);
type LINE_ATTRIBUTE is
( BOLD, -- Make words come out bold (overstrike)
CENTER, -- Center lines (Put_Line with No Fill)
FILL, -- Successively place words into an output
-- line until the next word will not fit
-- between the left and right margins
-- (with indents)
FILL_STATE_BEFORE_CENTER, -- Save area for FILL
JUSTIFY, -- Fill output line to RIGHT_MARGIN -
-- RIGHT_INDENT with spaces between words
PAGING, -- Break output on page boundaries,
-- outputting footer, bottom margin,
-- top margin, and header
UNDERLINE, -- Underline words
UNDERLINE_PUNCT, -- If ON, underline punctuation
USE_FORM_FEED -- Use form feeds to eject pages
);
type PAGE_ATTRIBUTE_LIST is
array (PAGE_ATTRIBUTE)
of NATURAL;
type OFF_ON is
( OFF, ON );
type LINE_ATTRIBUTE_LIST is
array (LINE_ATTRIBUTE)
of OFF_ON;
Page_Attribute_Defaults
: constant PAGE_ATTRIBUTE_LIST
:= (
TOP_MARGIN => 4,
BOTTOM_MARGIN => 4,
LEFT_MARGIN => 12,
RIGHT_MARGIN => 90,
LEFT_INDENT => 0,
RIGHT_INDENT => 0,
TOTAL_LINES => 66,
HEADER_LINES => 2,
FOOTER_LINES => 2,
LINE_SPACING => 0,
PAGE_OFFSET => 0,
TEMP_INDENT => 0 );
Line_Attribute_Defaults
: constant LINE_ATTRIBUTE_LIST
:= (
BOLD => OFF,
CENTER => OFF,
FILL => ON,
FILL_STATE_BEFORE_CENTER => ON,
JUSTIFY => ON,
PAGING => ON,
UNDERLINE => OFF,
UNDERLINE_PUNCT => OFF,
USE_FORM_FEED => ON );
Page_Number_Id_Default
: constant CHARACTER
:= '#';
type LINE_NUMBER is
new INTEGER range 0 .. Maximum_Number_Of_Lines_On_Page;
type HEADER_FOOTER_LINE is -- H/F line numbers
new INTEGER range 1 .. Maximum_Number_Of_Header_Footer_Lines;
type PAGE_NUMBER is
new INTEGER range 0 .. Maximum_Number_Of_Pages;
type STATUS is -- for Open
( OK, NOT_OK );
type PAGE_SIDE is -- for margins and indents
( LEFT_SIDE, RIGHT_SIDE );
type PAGE_KIND is -- for headers and footers
( EVEN_PAGES, ODD_PAGES, ALL_PAGES );
type NUMERIC_FORMAT is -- for page numbers
( ARABIC, LOWER_ROMAN, UPPER_ROMAN );
Range_Error
: exception;
File_Not_Open
: exception;
-- ..................................
-- . .
-- . FOF.Open . SPEC
-- . .
-- ..................................
procedure Open
( Item : in out FILE;
File_Name : in STRING;
Result : out STATUS );
--| Purpose
--| Open the formatted output file for subsequent processing.
--|
--| Exceptions (none)
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Close . SPEC
-- . .
-- ..................................
procedure Close
( Item : in FILE );
--| Purpose
--| Close the formatted output file.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Put_Invisible_Word . SPEC
-- . .
-- ..................................
procedure Put_Invisible_Word
( Item : in FILE;
What : in STRING );
--| Purpose
--| Add a word to the current line and do not increment the
--| character count.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Put_Word . SPEC
-- . .
-- ..................................
procedure Put_Word
( Item : in FILE;
What : in STRING );
--| Purpose
--| Add a word to the current line.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Put_Line . SPEC
-- . .
-- ..................................
procedure Put_Line
( Item : in FILE;
What : in STRING );
--| Purpose
--| Add a line to the current page. If line break, insert blank
--| lines as per LINE_SPACING.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Break_Line . SPEC
-- . .
-- ..................................
procedure Break_Line
( Item : in FILE );
--| Purpose
--| Break the current line (if it contains any words, output them).
--| Insert blank lines as per the LINE_SPACING setting.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Current_Line . SPEC
-- . .
-- ..................................
function Current_Line
( Item : in FILE )
return LINE_NUMBER;
--| Purpose
--| Return the number of the current line.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Skip . SPEC
-- . .
-- ..................................
procedure Skip
( Item : in FILE;
Number_Of_Lines : in LINE_NUMBER := 1 );
--| Purpose
--| Skip Number_Of_Lines in the output after first issuing a Break_Line.
--| LINE_SPACING influences the actual number of lines skipped.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Break_Page . SPEC
-- . .
-- ..................................
procedure Break_Page
( Item : in FILE );
--| Purpose
--| If there is anything on the current page, output it and advance
--| to the next page.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Break_Page . SPEC
-- . .
-- ..................................
procedure Break_Page
( Item : in FILE;
New_Page_Num : in PAGE_NUMBER );
--| Purpose
--| If there is anything on the current page, output it and advance
--| to the next page. Set the number of the next page to New_Page_Num.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Current_Page . SPEC
-- . .
-- ..................................
function Current_Page
( Item : in FILE )
return PAGE_NUMBER;
--| Purpose
--| Return the number of the current page.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Current_Page . SPEC
-- . .
-- ..................................
function Current_Page
( Item : in FILE )
return STRING;
--| Purpose
--| Return the number of the current page as a string.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Set_Page_Number_Format . SPEC
-- . .
-- ..................................
procedure Set_Page_Number_Format
( Item : in FILE;
To : in NUMERIC_FORMAT;
Format_String : in STRING );
--| Purpose
--| Set the format of the page number. If the Format_String is not
--| null, the page numbers in the headers and footers will appear as
--| indicated (with the literal number substituted for # characters).
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Set_Page_Attribute . SPEC
-- . .
-- ..................................
procedure Set_Page_Attribute
( Item : in FILE;
What : in PAGE_ATTRIBUTE;
To : in NATURAL );
--| Purpose
--| Set a specified page attribute.
--|
--| Exceptions
--| Range_Error raised if To is outside the range for What
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Set_Line_Attribute . SPEC
-- . .
-- ..................................
procedure Set_Line_Attribute
( Item : in FILE;
What : in LINE_ATTRIBUTE;
To : in OFF_ON );
--| Purpose
--| Turn off or on the indicated attribute for the current and
--| following lines.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Get_Page_Attribute . SPEC
-- . .
-- ..................................
function Get_Page_Attribute
( Item : in FILE;
What : in PAGE_ATTRIBUTE )
return NATURAL;
--| Purpose
--| Get a specified page attribute.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Get_Line_Attribute . SPEC
-- . .
-- ..................................
function Get_Line_Attribute
( Item : in FILE;
What : in LINE_ATTRIBUTE )
return OFF_ON;
--| Purpose
--| Get the indicated attribute for the current and
--| following lines.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Test_Page . SPEC
-- . .
-- ..................................
function Test_Page
( Item : in FILE;
Number_Of_Lines : in LINE_NUMBER )
return BOOLEAN;
--| Purpose
--| Return TRUE if Number_Of_Lines is remaining on the current page.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Set_Footer_Line . SPEC
-- . .
-- ..................................
procedure Set_Footer_Line
( Item : in FILE;
Class : in PAGE_KIND;
Number : in HEADER_FOOTER_LINE;
Left_Text : in STRING;
Center_Text : in STRING;
Right_Text : in STRING );
--| Purpose
--| Store a footer line for EVEN, ODD, or ALL pages.
--| The footer line is dynamically adjusted, based on the left and right
--| margin settings. The strings Left, Center, and Right are left-
--| justified, centered, and right-justified in the indicated footer
--| line, respectively.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Set_Header_Line . SPEC
-- . .
-- ..................................
procedure Set_Header_Line
( Item : in FILE;
Class : in PAGE_KIND;
Number : in HEADER_FOOTER_LINE;
Left_Text : in STRING;
Center_Text : in STRING;
Right_Text : in STRING );
--| Purpose
--| Store a header line for EVEN, ODD, or ALL pages.
--| The header line is dynamically adjusted, based on the left and right
--| margin settings. The strings Left, Center, and Right are left-
--| justified, centered, and right-justified in the indicated header
--| line, respectively.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Set_Page_Number_Id . SPEC
-- . .
-- ..................................
procedure Set_Page_Number_Id
( Item : in FILE;
To : in CHARACTER );
--| Purpose
--| Set the character used to represent the page number in the
--| header and footer lines of the output file.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Set_Page_Number_Format . SPEC
-- . .
-- ..................................
procedure Set_Page_Number_Format
( Item : in FILE;
To : in NUMERIC_FORMAT );
--| Purpose
--| Set the format used to represent the page number in the
--| header and footer lines of the output file.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
-- ..................................
-- . .
-- . FOF.Page_Number_Format . SPEC
-- . .
-- ..................................
function Page_Number_Format
( Item : in FILE )
return NUMERIC_FORMAT;
--| Purpose
--| Get the format used to represent the page number in the
--| header and footer lines of the output file.
--|
--| Exceptions
--| File_Not_Open
--|
--| Notes (none)
private -- Formatted_Output_File
type FILE_OBJECT;
type FILE is
access FILE_OBJECT;
end Formatted_Output_File;
--::::::::::
--hashfcns.spc
--::::::::::
-- *********************************************************
-- * *
-- * Hashing_Functions_PKG * SPEC
-- * *
-- *********************************************************
package Hashing_Functions_PKG is
--| Purpose
--| Provide a string hashing function.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Bill Toscano and Michael Gordon, Intermetrics
generic
Prime_Num: in POSITIVE; -- Required to be prime
function Hash_String (S: STRING) return NATURAL;
--| Purpose
--| Produces a uniform distribution over the range 0..prime - 1.
--|
--| Exceptions (none)
--| Notes (none)
end Hashing_Functions_PKG;
--::::::::::
--in.spc
--::::::::::
-- **********************************
-- * *
-- * Input_File * SPEC
-- * *
-- **********************************
package Input_File is
--| Purpose
--| Input_File implements an abstract data type of an input file.
--| Input_File offers an abstraction that can be made more efficient
--| by not using Text_IO (and having its associated overhead imposed)
--| if possible,
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| 08/16/89 Rick Conn Initial Version
type FILE_TYPE is
private;
Cannot_Open_Input_File
: exception;
Read_Error
: exception;
-- ..................................
-- . .
-- . Input_File.Open . SPEC
-- . .
-- ..................................
procedure Open
( Id : in out FILE_TYPE;
File_Name : in STRING );
--| Purpose
--| Open an existing FILE_TYPE object.
--|
--| Exceptions
--| Cannot_Open_Input_File
--|
--| Notes (none)
-- ..................................
-- . .
-- . Input_File.Get_Line . SPEC
-- . .
-- ..................................
procedure Get_Line
( Id : in out FILE_TYPE;
Item : out STRING;
Last : out NATURAL );
--| Purpose
--| Get_Line reads an Item to the FILE_TYPE object.
--|
--| Exceptions
--| Read_Error
--|
--| Notes (none)
-- ..................................
-- . .
-- . Input_File.End_Of_File . SPEC
-- . .
-- ..................................
function End_Of_File
( Id : in FILE_TYPE )
return BOOLEAN;
--| Purpose
--| End_Of_File returns TRUE if the FILE_TYPE object is empty or
--| no more data is in it.
--|
--| Exceptions
--| Read_Error
--|
--| Notes (none)
-- ..................................
-- . .
-- . Input_File.Close . SPEC
-- . .
-- ..................................
procedure Close
( Id : in out FILE_TYPE );
--| Purpose
--| Close closes input from the FILE_TYPE object.
--|
--| Exceptions (none)
--| Notes (none)
private -- Input_File
type FILE_OBJECT;
type FILE_TYPE is
access FILE_OBJECT;
end Input_File;
--::::::::::
--lists.spc
--::::::::::
-- *********************************************
-- * *
-- * LISTS * SPEC
-- * *
-- *********************************************
generic
type ITEMTYPE is private; -- This is the data being manipulated.
with function Equal (X,Y: in ITEMTYPE) return BOOLEAN is "=";
-- This allows the user to define
-- equality on ItemType. For instance
-- if ItemType is an abstract type
-- then equality is defined in terms of
-- the abstract type. If this function
-- is not provided equality defaults to
-- =.
package Lists is
--| Purpose
--| This package provides singly linked lists with elements of type
--| ItemType, where ItemType is specified by a generic parameter.
--|
--| When this package is instantiated, it provides a linked list type for
--| lists of objects of type ItemType, which can be any desired type. A
--| complete set of operations for manipulation, and releasing
--| those lists is also provided. For instance, to make lists of strings,
--| all that is necessary is:
--|
--| type StringType is string(1..10);
--|
--| package Str_List is new Lists(StringType); use Str_List;
--|
--| L:List;
--| S:StringType;
--|
--| Then to add a string S, to the list L, all that is necessary is
--|
--| L := Create;
--| Attach(S,L);
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Programmer Buddy Altus, Intermetrics
type LIST is private;
type LISTITER is private;
CircularList :exception; -- Raised if an attemp is made to
-- create a circular list. This
-- results when a list is attempted
-- to be attached to itself.
EmptyList :exception; -- Raised if an attemp is made to
-- manipulate an empty list.
ItemNotPresent :exception; -- Raised if an attempt is made to
-- remove an element from a list in
-- which it does not exist.
NoMore :exception; -- Raised if an attemp is made to
-- get the next element from a list
-- after iteration is complete.
-- .......................................................
-- . .
-- . LISTS.ATTACH . SPEC
-- . .
-- .......................................................
procedure Attach (List1: in out LIST; List2: in LIST);
--| Purpose
--| Appends List2 to List1. This makes the next field of the last element
--| of List1 refer to List2. This can possibly change the value of List1
--| if List1 is an empty list. This causes sharing of lists. Thus if
--| user Destroys List1 then List2 will be a dangling reference.
--| This procedure raises CircularList if List1 equals List2. If it is
--| necessary to Attach a list to itself first make a copy of the list and
--| attach the copy.
--|
--| Exceptions
--| CircularList
--|
--| Notes
-- .......................................................
-- . .
-- . LISTS.ATTACH . SPEC
-- . .
-- .......................................................
function Attach (Element1: in ITEMTYPE; Element2: in ITEMTYPE) return LIST;
--| Purpose
--| This creates a list containing the two elements in the order
--| specified.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.ATTACH . SPEC
-- . .
-- .......................................................
procedure Attach (L: in out LIST; Element: in ITEMTYPE);
--| Purpose
--| Appends Element onto the end of the list L. If L is empty then this
--| may change the value of L.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.ATTACH . SPEC
-- . .
-- .......................................................
procedure Attach (Element: in ITEMTYPE; L: in out LIST);
--| Purpose
--| This prepends list L with Element (makes Element the first item in
--| list L).
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.ATTACH . SPEC
-- . .
-- .......................................................
function Attach (List1: in LIST; List2: in LIST) return LIST;
--| Purpose
--| This returns a list which is List1 attached to List2. If it is desired
--| to make List1 be the new attached list the following ada code should be
--| used.
--|
--| List1 := Attach (List1, List2);
--|
--| This procedure raises CircularList if List1 equals List2. If it is
--| necessary to Attach a list to itself first make a copy of the list and
--| attach the copy.
--|
--| Exceptions
--| CircularList
--|
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.ATTACH . SPEC
-- . .
-- .......................................................
function Attach (Element: in ITEMTYPE; L: in LIST) return LIST;
--| Purpose
--| Returns a new list which is headed by Element and followed by L.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.ATTACH . SPEC
-- . .
-- .......................................................
function Attach (L: in LIST; Element: in ITEMTYPE) return LIST;
--| Purpose
--| Returns a new list which is L followed by Element.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.COPY . SPEC
-- . .
-- .......................................................
function Copy (L: in LIST) return LIST;
--| Purpose
--| Returns a copy of L.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.COPYDEEP . SPEC
-- . .
-- .......................................................
generic
with function Copy (I: in ITEMTYPE) return ITEMTYPE;
function CopyDeep (L: in LIST) return LIST;
--| Purpose
--| This produces a new list whose elements have been duplicated using
--| the Copy function provided by the user. This is helpful if the type
--| of a list is an abstract data type.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.CREATE . SPEC
-- . .
-- .......................................................
function Create return LIST;
--| Purpose
--| Returns an empty, initialized list.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.DELETEHEAD . SPEC
-- . .
-- .......................................................
procedure DeleteHead (L: in out LIST);
--| Purpose
--| This will return the space occupied by the first element in the list
--| to the heap. If sharing exists between lists this procedure
--| could leave a dangling reference. If L is empty, EmptyList will be
--| raised.
--|
--| Exceptions
--| EmptyList
--|
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.DELETEITEM . SPEC
-- . .
-- .......................................................
procedure DeleteItem (L: in out LIST; Element: in ITEMTYPE);
--| Purpose
--| Removes the first element of the list equal to Element. If there is
--| not an element equal to Element, then ItemNotPresent is raised.
--|
--| This operation is destructive; it returns the storage occupied by
--| the elements being deleted.
--|
--| Exceptions
--| ItemNotPresent
--|
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.DELETEITEM . SPEC
-- . .
-- .......................................................
function DeleteItem (L: in LIST; Element: in ITEMTYPE) return LIST;
--| Purpose
--| This returns the List L with the first occurrence of Element removed.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.DELETEITEMS . SPEC
-- . .
-- .......................................................
function DeleteItems (L: in LIST; Element: in ITEMTYPE) return LIST;
--| Purpose
--| This function returns a copy of the list L which has all elements which
--| have value Element removed.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.DELETEITEMS . SPEC
-- . .
-- .......................................................
procedure DeleteItems (L: in out LIST; Element: in ITEMTYPE);
--| Purpose
--| This procedure removes all occurrences of Element from the List L. This
--| is a destructive procedure.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.DESTROY . SPEC
-- . .
-- .......................................................
procedure Destroy (L: in out LIST);
--| Purpose
--| This returns to the heap all the storage that a list occupies. Keep in
--| mind if there exists sharing between lists then this operation can leave
--| dangling references.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.DESTROYDEEP . SPEC
-- . .
-- .......................................................
generic
with procedure Dispose (I :in out ITEMTYPE);
procedure DestroyDeep (L :in out LIST);
--| Purpose
--| This procedure is used to destroy a list and all the objects contained
--| in an element of the list. For example if L is a list of lists
--| then destroy L does not destroy the lists which are elements of L.
--| DestroyDeep will now destroy L and all the objects in the elements of L.
--| The produce Dispose is a procedure which will destroy the objects which
--| comprise an element of a list. For example if package L was a list
--| of lists then Dispose for L would be the Destroy of list type package L was
--| instantiated with.
--|
--| This procedure requires no sharing between elements of lists.
--| For example, if L_int is a list of integers and L_of_L_int is a list
--| of lists of integers and two elements of L_of_L_int have the same value
--| then doing a DestroyDeep will cause an access violation to be raised.
--| The best way to avoid this is not to have sharing between list elements
--| or use copy functions when adding to the list of lists.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.FIRSTVALUE . SPEC
-- . .
-- .......................................................
function FirstValue (L: in LIST) return ITEMTYPE;
--| Purpose
--| This returns the Item in the first position in the list. If the list
--| is empty EmptyList is raised.
--|
--| Exceptions
--| EmptyList
--|
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.FORWARD . SPEC
-- . .
-- .......................................................
procedure Forward (I :in out LISTITER);
--| Purpose
--| This procedure can be used in conjunction with Cell to iterate over a list.
--| This is in addition to Next. Instead of writing
--|
--| I :ListIter;
--| L :List;
--| V :List_Element_Type;
--|
--| I := MakeListIter(L);
--| while More(I) loop
--| Next (I, V);
--| Print (V);
--| end loop;
--|
--| One can write
--|
--| I := MakeListIter(L);
--| while More (I) loop
--| Print (Cell (I));
--| Forward (I);
--| end loop;
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.ISEMPTY . SPEC
-- . .
-- .......................................................
function IsEmpty (L: in LIST) return BOOLEAN;
--| Purpose
--| Return TRUE iff L is empty.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.ISINLIST . SPEC
-- . .
-- .......................................................
function IsInList (L: in LIST; Element: in ITEMTYPE) return BOOLEAN;
--| Purpose
--| Walks down the list L looking for an element whose value is Element.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.LASTVALUE . SPEC
-- . .
-- .......................................................
function LastValue (L: in LIST) return ITEMTYPE;
--| Purpose
--| Returns the last element in a list. If the list is empty EmptyList is
--| raised.
--|
--| Exceptions
--| EmptyList
--|
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.LENGTH . SPEC
-- . .
-- .......................................................
function Length (L: in LIST) return INTEGER;
--| Purpose
--| Count the number of elements in list L.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.LENGTH . SPEC
-- . .
-- .......................................................
function MakeList (E :in ITEMTYPE) return LIST;
--| Purpose
--| Takes in an element and returns a list.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.MAKELISTITER . SPEC
-- . .
-- .......................................................
function MakeListIter (L: in LIST) return LISTITER;
--| Purpose
--| This prepares a user for iteration operation over a list. The iterater is
--| an operation which returns successive elements of the list on successive
--| calls to the iterator. There needs to be a mechanism which marks the
--| position in the list, so on successive calls to the Next operation the
--| next item in the list can be returned. This is the function of the
--| MakeListIter and the type ListIter. MakeIter just sets the Iter to the
--| the beginning of the list. On subsequent calls to Next the Iter
--| is updated with each call.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.MORE . SPEC
-- . .
-- .......................................................
function More (L: in LISTITER) return BOOLEAN;
--| Purpose
--| Returns TRUE iff there are more elements in the list.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.NEXT . SPEC
-- . .
-- .......................................................
procedure Next (Place: in out LISTITER; Info: out ITEMTYPE);
--| Purpose
--| This is the iterator operation. Given a ListIter, Next returns the
--| current item and updates the ListIter.
--|
--| The iterators subprograms MakeListIter, More, and Next should be used
--| in the following way:
--|
--| L: List;
--| Place: ListIter;
--| Info: SomeType;
--|
--|
--| Place := MakeListIter(L);
--|
--| while ( More(Place) ) loop
--| Next(Place, Info);
--| process each element of list L;
--| end loop;
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.REPLACEHEAD . SPEC
-- . .
-- .......................................................
procedure ReplaceHead (L: in out LIST; Info: in ITEMTYPE);
--| Purpose
--| Replaces the information in the first element in the list. Raises
--| EmptyList if the list is empty.
--|
--| Exceptions
--| EmptyList
--|
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.REPLACETAIL . SPEC
-- . .
-- .......................................................
procedure ReplaceTail (L: in out LIST; NewTail: in LIST);
--| Purpose
--| Replaces the tail of a list with a new list. If the list whose tail
--| is being replaced is null EmptyList is raised.
--|
--| Exceptions
--| EmptyList
--|
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.TAIL . SPEC
-- . .
-- .......................................................
function Tail (L: in LIST) return LIST;
--| Purpose
--| Returns a list which is the tail of the list L. Raises EmptyList if
--| L is empty. If L only has one element then Tail returns the Empty
--| list.
--|
--| Exceptions
--| EmptyList
--|
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.CELLVALUE . SPEC
-- . .
-- .......................................................
function CellValue (I :in LISTITER) return ITEMTYPE;
--| Purpose
--| This returns the value of the element at the position of the iterator.
--| This is used in conjunction with Forward.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . LISTS.EQUAL . SPEC
-- . .
-- .......................................................
function Equal (List1: in LIST; List2: in LIST) return BOOLEAN;
--| Purpose
--| Returns true if for all elements of List1 the corresponding element
--| of List2 has the same value. This function uses the Equal operation
--| provided by the user. If one is not provided then = is used.
--|
--| Exceptions (none)
--| Notes (none)
private
type CELL;
type LIST is access CELL; -- pointer added by this package
-- in order to make a list
type CELL is -- Cell for the lists being created
record
Info : ITEMTYPE;
Next : LIST;
end record;
type LISTITER is new LIST; -- This prevents Lists being assigned to
-- iterators and vice versa
end Lists;
--::::::::::
--logical.spc
--::::::::::
-- ***************************************************************
-- * *
-- * LOGICAL * SPEC
-- * *
-- ***************************************************************
package Logical is
--| Purpose
--| LOGICAL provides bit-level manipulation on INTEGER objects.
--|
--| Initialization Exceptions (none)
--| Notes
--| Not all MIL-HDBK-1804 PDL annotations are
--| used in this package due to its simplicity.
--| No exceptions are raised by this package.
--|
--| Modifications
--| Author: Joseph Orost, Concurrent Computer Corporation
-- ..................................................................
-- . .
-- . LOGICAL.ROTATE . SPEC
-- . .
-- ..................................................................
function Rotate (Arg, Count : INTEGER) return INTEGER;
--| Purpose
--| Return arg rotated count bits.
--| If count < 0, rotate is to the right,
--| else, rotate is to the left.
-- ..................................................................
-- . .
-- . LOGICAL.SHIFT . SPEC
-- . .
-- ..................................................................
function Shift (Arg, Count : INTEGER) return INTEGER;
--| Purpose
--| Return arg logically shifted count bits.
--| Bits shifted out either end are lost.
--| If count < 0, shift is to the right,
--| else, shift is to the left
-- ..................................................................
-- . .
-- . LOGICAL."xor" . SPEC
-- . .
-- ..................................................................
function "xor" (Left, Right : INTEGER) return INTEGER;
--| Purpose
--| Return left XOR right.
-- ..................................................................
-- . .
-- . LOGICAL."and" . SPEC
-- . .
-- ..................................................................
function "and" (Left, Right : INTEGER) return INTEGER;
--| Purpose
--| Return left AND right.
-- ..................................................................
-- . .
-- . LOGICAL."or" . SPEC
-- . .
-- ..................................................................
function "or" (Left, Right : INTEGER) return INTEGER;
--| Purpose
--| Return left OR right.
-- ..................................................................
-- . .
-- . LOGICAL."not" . SPEC
-- . .
-- ..................................................................
function "not" (Right : INTEGER) return INTEGER;
--| Purpose
--| Return NOT right.
end Logical;
--::::::::::
--lparse.spc
--::::::::::
-- *****************************************************
-- * *
-- * LINE_PARSER * SPEC
-- * *
-- *****************************************************
package Line_Parser is
--| Purpose
--| Line_Parser parses strings in a manner similar to ARGC/ARGV
--| under UNIX. Function ARGC returns a count of the number of
--| tokens in the string and function ARGV returns each token
--| as a separate substring.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Richard Conn
-- .................................................
-- . .
-- . LINE_PARSER.INITIALIZE . SPEC
-- . .
-- .................................................
procedure Initialize (Item : in STRING);
--| Purpose
--| Initialize this package. This routine MUST be called
--| before any other routines.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LINE_PARSER.ARGC . SPEC
-- . .
-- ....................................................
function ArgC return NATURAL;
--| Purpose
--| Return the number of tokens in the string.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . LINE_PARSER.ARGV . SPEC
-- . .
-- ...................................................
function ArgV (Index : in NATURAL) return STRING;
--| Purpose
--| Return the Nth token in the string (the first token is
--| numbered 0). Valid values for INDEX are from 0 to
--| ARGC-1.
--|
--| Exceptions
--| INVALID_INDEX is raised if INDEX > ARGC-1
--|
--| Notes (none)
INVALID_INDEX : exception;
UNEXPECTED_ERROR : exception;
end Line_Parser;
--::::::::::
--matrix.spc
--::::::::::
-- ****************************************************************
-- * *
-- * Matrix_Package * SPEC
-- * *
-- ****************************************************************
package MATRIX_PACKAGE is
--| Purpose
--| This package is a general purpose matrix package. It defines data
--| types VECTOR and MATRIX, and contains functions to perform general
--| matrix algebra operations.
--|
--| Initialization Exceptions (none)
--|
--| Notes
--| Not all MIL-HDBK-1804 PDL annotations are used in this package
--| due to its simplicity.
--|
--| Modifications
--| Author: Dr. Roger Lee, Naval Air Development Center
--| Art Adamson, Consultant
-- Types
type VECTOR is array(integer range<>) of float ;
subtype VEC2T is VECTOR (integer range 1..2) ;
subtype VEC3T is VECTOR (integer range 1..3) ;
type MATRIX is array(integer range<>,integer range <>) of float;
type MATR2T is array(integer range<>) of VEC2T;
-- Exceptions
INCOMPARABLE_DIMENSION :exception; -- the dimension of matrices
-- or vectors to be operated are
-- incomparable
SINGULAR : exception; -- matrix to be inverted is singular
-- Operations
function TRANSPOSE(A : MATRIX) return MATRIX ; -- transpose of matrix
function TRANSPOSE(A : VECTOR) return VECTOR ; -- transpose of vector
function "+" (A : VECTOR; B : VECTOR) return VECTOR ; -- sum of vector
function "+" (A : MATRIX; B : MATRIX) return MATRIX ; -- sum of matrix
function "+" (A : float; B : VECTOR) return VECTOR ;
-- float added to, each term of matrix
function "+" (A : VEC2T; B : MATR2T) return MATR2T ;
-- Vec2T added to, each term of MATR2T
function "+" (A : MATR2T; B : MATR2T) return MATR2T ;
-- Corressponding terms added.
function "-" (A : VECTOR; B : VECTOR) return VECTOR ;
-- difference of vector
function "-" (A : MATRIX; B : MATRIX) return MATRIX ;
-- difference of matrix
function "*" (A : float; B : VECTOR) return VECTOR ;
-- scalar, vector multiplication
function "*" (A : VECTOR; B : float) return VECTOR ;
-- vector, scalar multiplication
function "*" (A : VECTOR; B : VECTOR) return float ;
-- inner(dot) product of two vectors
function "*" (A : MATRIX; B : VECTOR) return VECTOR ;
-- matrix,column vector multiplication
function mat4mult(UL : MATRIX; UR : MATRIX; BL : MATRIX; BR : MATRIX;
B : VECTOR) return VECTOR ;
-- large matrix broken into 4 smaller ones, column vector multiplication
-- (upper left, upper right, bottom left, bottom right--all square)
function "*" (A : VECTOR; B : MATRIX) return VECTOR ;
-- row vector,matrix multiplication
function "*" (A : float; B : MATRIX) return MATRIX ;
-- scalar, matrix multiplication
function "*" (A : MATRIX; B : float) return MATRIX ;
-- matrix, scalar multiplication
function "*" (A : MATRIX; B : MATRIX) return MATRIX ;
-- matrix, matrix multiplication
function "*" (A : float; B : MATR2T) return MATR2T ;
-- Multiplies each term of a MATR2T by a float
function "*" (A : VEC2T; B : MATR2T) return VECTOR ;
-- Dot product of each term of MATR2T by a VEC2T, return array of floats
function "*" (A : VECTOR; B : MATR2T) return MATR2T ;
--Multiplies each term of VEC2T by a corresponding float from a VECTOR
function "**"(A : MATRIX; P : integer) return MATRIX;
-- square matrix raised to integer power
-- if P = -1, we invert the matrix
function "**" (A : VECTOR; B : VECTOR) return VECTOR ;
-- A X B = ab sin(theta) a direction
--perpendicular to plane of A & B.
function JCROSS (A : VEC2T) return VEC2T ;
--Rotates Vec2T 90 degrees CW.
function JCROSS (A : MATR2T) return MATR2T ;
--Rotates Vec2T's 90 degrees CW.
function ROTX (A : VEC2T) return VEC2T ;
--Rotates Vec2T 180 degrees about the X axis.
function ROTY (A : VEC2T) return VEC2T ;
--Rotates Vec2T 180 degrees about the Y axis.
function aXbDOTj(A : VEC2T; B : VEC2T) return FLOAT;
--Gets magnitude of A cross B for 2 2D vectors.
function GETTAN (A : VEC2T; B : VEC2T) return FLOAT;
--Gets TAN(THETA) between 2 2D vectors.
end MATRIX_PACKAGE;
--::::::::::
--mlib.spc
--::::::::::
-- ***************************************************************
-- * *
-- * FLOATING_CHARACTERISTICS * SPEC
-- * *
-- ***************************************************************
package Floating_Characteristics is
--| Purpose
--| This package is a floating mantissa definition of a binary FLOAT
--| It was first used on the DEC-10 and the VAX but should work for any
--| since the parameters are obtained by initializing on the actual hardware.
--| Otherwise the parameters could be set in the spec if known.
--| This is a preliminary package that defines the properties
--| of the particular floating point type for which we are going to
--| generate the math routines.
--| The constants are those required by the routines described in
--| "Software Manual for the Elementary Functions" W. Cody & W. Waite
--| Prentice-Hall 1980.
--| Actually most are needed only for the test programs
--| rather than the functions themselves, but might as well be here.
--| Most of these could be in the form of attributes if
--| all the floating types to be considered were those built into the
--| compiler, but we also want to be able to support user defined types
--| such as software floating types of greater precision than
--| the hardware affords, or types defined on one machine to
--| simulate another.
--| So we use the Cody-Waite names and derive them from an adaptation
--| of the MACHAR routine as given by Cody-Waite in Appendix B.
--|
--| Initialization Exceptions (none)
--|
--| Notes
--| Not all MIL-HDBK-1804 PDL annotations are
--| used in this package due to its simplicity.
--|
--| Modifications
--| Author: Major Terry Courtwright, World Wide Military Command and
--| Control Information Systems Joint Program Management Office
Ibeta : INTEGER;
-- The radix of the floating-point representation
It : INTEGER;
-- The number of base IBETA digits in the DIS_FLOAT significand
Irnd : INTEGER;
-- TRUE (1) if floating addition rounds, FALSE (0) if truncates
Ngrd : INTEGER;
-- Number of guard digits for multiplication
Machep : INTEGER;
-- The largest negative integer such that
-- 1.0 + FLOAT(IBETA) ** MACHEP /= 1.0
-- except that MACHEP is bounded below by -(IT + 3)
Negep : INTEGER;
-- The largest negative integer such that
-- 1.0 -0 FLOAT(IBETA) ** NEGEP /= 1.0
-- except that NEGEP is bounded below by -(IT + 3)
Iexp : INTEGER;
-- The number of bits (decimal places if IBETA = 10)
-- reserved for the representation of the exponent (including
-- the bias or sign) of a floating-point number
Minexp : INTEGER;
-- The largest in magnitude negative integer such that
-- FLOAT(IBETA) ** MINEXP is a positive floating-point number
Maxexp : INTEGER;
-- The largest positive exponent for a finite floating-point number
Eps : FLOAT;
-- The smallest positive floating-point number such that
-- 1.0 + EPS /= 1.0
-- In particular, if IBETA = 2 or IRND = 0,
-- EPS = FLOAT(IBETA) ** MACHEP
-- Otherwise, EPS = (FLOAT(IBETA) ** MACHEP) / 2
Epsneg : FLOAT;
-- A small positive floating-point number such that 1.0-EPSNEG /= 1.0
Xmin : FLOAT;
-- The smallest non-vanishing floating-point power of the radix
-- In particular, XMIN = FLOAT(IBETA) ** MINEXP
Xmax : FLOAT;
-- The largest finite floating-point number
-- Here the structure of the floating type is defined.
-- I have assumed that the exponent is always some integer form.
-- The mantissa can vary.
-- Most often it will be a fixed type or the same floating type
-- depending on the most efficient machine implementation.
-- Most efficient implementation may require details of the machine hardware
-- In this version the simplest representation is used.
-- The mantissa is extracted into a FLOAT and uses the predefined operations.
subtype EXPONENT_TYPE is INTEGER; -- should be derived
subtype MANTISSA_TYPE is FLOAT; -- range -1.0..1.0;
-- A consequence of the rigorous constraints on MANTISSA_TYPE is that
-- operations must be very carefully examined to make sure that no number
-- greater than one results.
-- Actually this limitation is important in constructing algorithms
-- which will also run when MANTISSA_TYPE is a fixed point type.
-- If we are not using the STANDARD type, we have to define all the
-- operations at this point.
-- We also need PUT for the type if it is not otherwise available.
-- Now we do something strange.
-- Since we do not know in the following routines whether the mantissa
-- will be carried as a fixed or floating type, we have to make some
-- provision for dividing by two.
-- We cannot use the literals, since FIXED/2.0 and FLOAT/2 will fail.
-- We define a type-dependent factor that will work.
Mantissa_Divisor_2 : constant FLOAT := 2.0;
Mantissa_Divisor_3 : constant FLOAT := 3.0;
-- This will work for the MANTISSA_TYPE defined above.
-- The alternative of defining an operation "/" to take care of it
-- is too sweeping and would allow unAda-like errors.
Mantissa_Half : constant MANTISSA_TYPE := 0.5;
-- Subprograms
procedure Defloat (X : in FLOAT;
L : out EXPONENT_TYPE;
E : out MANTISSA_TYPE);
procedure Refloat (N : in EXPONENT_TYPE;
F : in MANTISSA_TYPE;
Z : out FLOAT);
-- Since the user may wish to define a floating type by some other name
-- CONVERT_TO_FLOAT is used rather than just FLOAT for explicit coersion.
function Convert_to_Float (K : INTEGER) return FLOAT;
--function CONVERT_TO_FLOAT(N : EXPONENT_TYPE) return FLOAT;
function Convert_to_Float (F : MANTISSA_TYPE) return FLOAT;
end Floating_Characteristics;
-- ***************************************************************
-- * *
-- * NUMERIC_PRIMITIVES * SPEC
-- * *
-- ***************************************************************
with Floating_Characteristics;
use Floating_Characteristics;
package Numeric_Primitives is
--| Purpose
--| This package contains the definitions of several useful constants
--| and functions associated with FLOAT numbers.
--|
--| Initialization Exceptions (none)
--|
--| Notes
--| Due to the simplicity of this package, the MIL-HDBK-1804 PDL
--| annotations are not used in the rest of this specification.
--|
--| Modifications
--| Author: Major Terry Courtwright, World Wide Military Command and
--| Control Information Systems Joint Program Management Office
-- This may seem a little much but is put in this form to allow the
-- same form to be used for a generic package.
-- If that is not needed, simple litterals could be substituted.
Zero : FLOAT;
One : FLOAT;
Two : FLOAT;
Three : FLOAT;
Half : FLOAT;
-- The following "constants" are effectively deferred to
-- the initialization part of the package body.
-- This is in order to make it possible to generalize the floating type.
-- If that capability is not desired, constants may be included here.
PI : FLOAT;
One_Over_PI : FLOAT;
Two_Over_PI : FLOAT;
PI_Over_Two : FLOAT;
PI_Over_Three : FLOAT;
PI_Over_Four : FLOAT;
PI_Over_Six : FLOAT;
-- Subprograms
function Sign (X, Y : FLOAT) return FLOAT;
-- Returns the value of X with the sign of Y.
function Max (X, Y : FLOAT) return FLOAT;
-- Returns the algebraicly larger of X and Y.
function Truncate (X : FLOAT) return FLOAT;
-- Returns the floating value of the integer no larger than X.
-- AINT(X)
function Round (X : FLOAT) return FLOAT;
-- Returns the floating value nearest X.
-- AINTRND(X)
function Ran return FLOAT;
-- This uses a portable algorithm and is included at this point.
-- Algorithms that presume unique machine hardware information
-- should be initiated in FLOATING_CHARACTERISTICS.
end Numeric_Primitives;
-- ***************************************************************
-- * *
-- * CORE_FUNCTIONS * SPEC
-- * *
-- ***************************************************************
with Floating_Characteristics;
use Floating_Characteristics;
package Core_Functions is
--| Purpose
--| This package contains the definitions of several fundamental
--| functions associated with FLOAT numbers.
--|
--| Initialization Exceptions (none)
--|
--| Notes
--| Due to the simplicity of this package, the MIL-HDBK-1804 PDL
--| annotations are not used in the rest of this specification.
--|
--| Modifications
--| Author: Major Terry Courtwright, World Wide Military Command and
--| Control Information Systems Joint Program Management Office
Exp_Large : FLOAT;
Exp_Small : FLOAT;
-- Subprograms
function SQRT(X : FLOAT) return FLOAT;
function CBRT(X : FLOAT) return FLOAT;
function LOG(X : FLOAT) return FLOAT;
function LOG10(X : FLOAT) return FLOAT;
function EXP(X : FLOAT) return FLOAT;
function "**"(X, Y : FLOAT) return FLOAT;
end Core_Functions;
-- ***************************************************************
-- * *
-- * TRIG_FUNCTIONS * SPEC
-- * *
-- ***************************************************************
package Trig_Functions is
--| Purpose
--| This package contains the definitions of several trigonometric
--| and hypertrigonometic functions associated with FLOAT numbers.
--|
--| Initialization Exceptions (none)
--|
--| Notes
--| Due to the simplicity of this package, the MIL-HDBK-1804 PDL
--| annotations are not used in the rest of this specification.
--|
--| Modifications
--| Author: Major Terry Courtwright, World Wide Military Command and
--| Control Information Systems Joint Program Management Office
function SIN(X : FLOAT) return FLOAT;
function COS(X : FLOAT) return FLOAT;
function TAN(X : FLOAT) return FLOAT;
function COT(X : FLOAT) return FLOAT;
function ASIN(X : FLOAT) return FLOAT;
function ACOS(X : FLOAT) return FLOAT;
function ATAN(X : FLOAT) return FLOAT;
function ATAN2(V, U : FLOAT) return FLOAT;
function SINH(X : FLOAT) return FLOAT;
function COSH(X : FLOAT) return FLOAT;
function TANH(X : FLOAT) return FLOAT;
end Trig_Functions;
--::::::::::
--out.spc
--::::::::::
-- **********************************
-- * *
-- * Output_File * SPEC
-- * *
-- **********************************
package Output_File is
--| Purpose
--| Output_File implements an abstract data type of an output file.
--| Output_File offers an abstraction that can be made more efficient
--| by not using Text_IO (and having its associated overhead imposed)
--| if possible and also offers the ability to suppress the output,
--| which may be desired if a caller is skipping over pages and just
--| wants to output to a null device during this process.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| 08/16/89 Rick Conn Initial Version
type FILE_TYPE is
private;
Cannot_Create_Output_File
: exception;
Write_Error
: exception;
-- ..................................
-- . .
-- . Output_File.Already_Exists . SPEC
-- . .
-- ..................................
function Already_Exists
( File_Name : in STRING )
return BOOLEAN;
--| Purpose
--| Determine if the FILE_TYPE object already exists.
--|
--| Exceptions (none)
--| Notes (none)
-- ..................................
-- . .
-- . Output_File.Delete . SPEC
-- . .
-- ..................................
function Delete
( File_Name : in STRING )
return BOOLEAN;
--| Purpose
--| Delete the FILE_TYPE object. Return TRUE if successful.
--|
--| Exceptions (none)
--| Notes (none)
-- ..................................
-- . .
-- . Output_File.Create . SPEC
-- . .
-- ..................................
procedure Create
( Id : in out FILE_TYPE;
File_Name : in STRING );
--| Purpose
--| Create creates a new FILE_TYPE object.
--|
--| Exceptions
--| Cannot_Create_Output_File
--|
--| Notes (none)
-- ..................................
-- . .
-- . Output_File.Put . SPEC
-- . .
-- ..................................
procedure Put
( Id : in out FILE_TYPE;
Item : in CHARACTER );
procedure Put
( Id : in out FILE_TYPE;
Item : in STRING );
--| Purpose
--| Put writes an Item to the FILE_TYPE object.
--|
--| Exceptions
--| Write_Error
--|
--| Notes (none)
-- ..................................
-- . .
-- . Output_File.Put_Line . SPEC
-- . .
-- ..................................
procedure Put_Line
( Id : in out FILE_TYPE;
Item : in STRING );
--| Purpose
--| Put_Line writes an Item to the FILE_TYPE object. The Item is followed
--| by a New_Line;
--|
--| Exceptions
--| Write_Error
--|
--| Notes (none)
-- ..................................
-- . .
-- . Output_File.New_Line . SPEC
-- . .
-- ..................................
procedure New_Line
( ID : in out FILE_TYPE );
--| Purpose
--| New_Line writes an end-of-line sequence to the FILE_TYPE object.
--|
--| Exceptions
--| Write_Error
--|
--| Notes (none)
-- ..................................
-- . .
-- . Output_File.New_Page . SPEC
-- . .
-- ..................................
procedure New_Page
( ID : in out FILE_TYPE );
--| Purpose
--| New_Page writes an end-of-page sequence to the FILE_TYPE object.
--|
--| Exceptions
--| Write_Error
--|
--| Notes (none)
-- ..................................
-- . .
-- . Output_File.Enable_Output . SPEC
-- . Output_File.Disable_Output .
-- . .
-- ..................................
procedure Enable_Output
( ID : in out FILE_TYPE );
procedure Disable_Output
( ID : in out FILE_TYPE );
--| Purpose
--| Enable_Output and Disable_Output enable and disable the output of
--| Items and new lines to the FILE_TYPE object. When created, output
--| to a FILE_TYPE object is enabled.
--|
--| Exceptions (none)
--| Notes (none)
-- ..................................
-- . .
-- . Output_File.Close . SPEC
-- . .
-- ..................................
procedure Close
( ID : in out FILE_TYPE );
--| Purpose
--| Close closes output to the FILE_TYPE object.
--|
--| Exceptions (none)
--| Notes (none)
private -- Output_File
type FILE_OBJECT;
type FILE_TYPE is
access FILE_OBJECT;
end Output_File;
--::::::::::
--permutat.spc
--::::::::::
-- ****************************************************
-- * *
-- * Permutations_Class * SPEC
-- * *
-- ****************************************************
generic
type ITEM_TYPE is private;
type INDEX_TYPE is (<>);
type LIST_TYPE is array (INDEX_TYPE range <>) of ITEM_TYPE;
package Permutations_Class is
--| Purpose
--| Generate all permutations of a set of ITEM_TYPE objects.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Doug Bryan, Stanford University
-- ........................................................
-- . .
-- . Permutations_Class.Iterate_Through_Length... . SPEC
-- . .
-- ........................................................
generic
with procedure Process (A_Permutation : LIST_TYPE);
procedure Iterate_Through_Length_Factorial_Permutations
(Of_Items : LIST_TYPE);
--| Purpose
--| For an actual parameter for Of_Items of length n,
--| n! (n factorial) permutations will be produced.
--|
--| The procedure permutes the elements in the array ITEMS.
--| actually it permutes their indicies and re-arranges the items
--| within the list. The procedure does not care of any or all
--| of the items in the list are equal (the same).
--|
--| Exceptions (none)
--| Notes (none)
end Permutations_Class;
--::::::::::
--priqueue.spc
--::::::::::
-- ********************************************************
-- * *
-- * PRIORITIZED_QUEUE * SPEC
-- * *
-- ********************************************************
generic
type ENQUEUED_OBJECT is limited private;
type PRIORITY_VALUE is (<>);
with procedure Assign (Target : in out ENQUEUED_OBJECT;
Source : in ENQUEUED_OBJECT) is <>;
with function "=" (First_Object : in ENQUEUED_OBJECT;
Second_Object : in ENQUEUED_OBJECT) return BOOLEAN is <>;
with procedure Destroy (Targeted_Object : in out ENQUEUED_OBJECT) is <>;
with function "<" (First_Object : in PRIORITY_VALUE;
Second_Object : in PRIORITY_VALUE) return BOOLEAN is <>;
package Prioritized_Queue is
--| Purpose
--| Support prioritized queues. Items may be added to removed
--| from these queues based on priority, as opposed to first
--| arrival.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Bill Wolfe, Clemson University
-- *******************************************************
-- This software is part of the Clemson University
-- Computer Science Department's Ada Software
-- Repository, and is copyrighted (C) 1989 by
-- Clemson University. Permission to copy without
-- fee all or part of this software is granted,
-- provided that the copies are not made or
-- distributed for direct commercial advantage, and
-- that this copyright notice is not deleted or
-- modified. To copy otherwise, or to republish,
-- requires a fee and/or specific permission.
-- *******************************************************
type PRIORITY_QUEUE is limited private;
-- requires O (n) space, where n is the NUMBER_OF_ITEMS in the queue.
Requested_Item_Does_Not_Exist_In_This_Priority_Queue : EXCEPTION;
No_Items_Currently_Exist_In_This_Empty_Priority_Queue : EXCEPTION;
type POINTER_TO_PRIORITY_QUEUE is access PRIORITY_QUEUE;
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.DESTROY . SPEC
-- . .
-- ..........................................................
procedure Destroy (Targeted_Object : in out POINTER_TO_PRIORITY_QUEUE);
--| Purpose
--| Remove the queue, freeing the space allocated to it.
--|
--| Exceptions (none)
--|
--| Notes
--| Unlike UNCHECKED_DEALLOCATION, this procedure will properly
--| destroy the PRIORITY_QUEUE being pointed to. Works in O (n)
--| time, where n is the NUMBER_OF_ITEMS in the PRIORITY_QUEUE
--| being pointed to.
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.INSERT_ITEM . SPEC
-- . .
-- ..........................................................
procedure Insert_Item (Queue : in out PRIORITY_QUEUE;
Object : in ENQUEUED_OBJECT;
Priority : in PRIORITY_VALUE);
--| Insert the indicated OBJECT into the QUEUE at the given PRIORITY.
--|
--| Exceptions (none)
--|
--| Notes
--| The QUEUE can safely handle multiple instances of a given
--| (OBJECT, PRIORITY) pair. Works in O (log n) time, where n
--| is the NUMBER_OF_ITEMS in the updated QUEUE.
--| A series of consecutive initializing insertions uses O (n) time,
--| where n is the number of insertions.
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.REMOVE_HIGHEST_PRIORITY_OBJECT . SPEC
-- . .
-- ..........................................................
procedure Remove_Highest_Priority_Object
(Highest_Priority_Object : in out ENQUEUED_OBJECT;
Queue : in out PRIORITY_QUEUE);
--| Purpose
--| Remove the highest priority object. If there are several objects
--| of the same highest priority, the first object entered will be
--| removed.
--|
--| Exceptions
--| No_Items_Currently_Exist_In_This_Empty_Priority_Queue
--|
--| Notes
--| Works in O (log n) time, where n is the NUMBER_OF_ITEMS
--| originally in the QUEUE. Raises
--| No_Items_Currently_Exist_In_This_Empty_Priority_Queue
--| if the QUEUE is EMPTY.
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.REMOVE_HIGHEST_PRIORITY_OBJECT . SPEC
-- . .
-- ..........................................................
procedure Remove_Highest_Priority_Object
(Highest_Priority_Object : in out ENQUEUED_OBJECT;
Priority_of_the_Object : out PRIORITY_VALUE;
Queue : in out PRIORITY_QUEUE);
--| Purpose
--| Remove the highest priority object in a queue, returning both
--| the object and its priority.
--|
--| Exceptions
--| No_Items_Currently_Exist_In_This_Empty_Priority_Queue
--|
--| Notes
--| Works in O (log n) time, where n is the NUMBER_OF_ITEMS
--| originally in the QUEUE.
--| Raises No_Items_Currently_Exist_In_This_Empty_Priority_Queue
--| if the QUEUE is EMPTY.
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.DELETE_ITEM . SPEC
-- . .
-- ..........................................................
procedure Delete_Item (Queue : in out PRIORITY_QUEUE;
Object : in ENQUEUED_OBJECT;
Priority : in PRIORITY_VALUE);
--| Purpose
--| Delete an item in the queue given the item and its priority.
--|
--| Exceptions
--| Requested_Item_Does_Not_Exist_In_This_Priority_Queue
--| No_Items_Currently_Exist_In_This_Empty_Priority_Queue
--|
--| Notes
--| Works in O (n) time, where n is the NUMBER_OF_ITEMS originally
--| in the QUEUE.
--|
--| If multiple occurrences of the specified OBJECT and PRIORITY
--| exist, the first such occurrence found will be deleted, and
--| all others will be left undisturbed.
--| PURGE_ITEM should be used if you wish to eliminate all such
--| occurrences.
--|
--| If no occurrences of the specified OBJECT and PRIORITY exist,
--| and the queue is not EMPTY, raises
--| Requested_Item_Does_Not_Exist_In_This_Priority_Queue.
--|
--| If the QUEUE is EMPTY, raises
--| No_Items_Currently_Exist_In_This_Empty_Priority_Queue.
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.PURGE_ITEM . SPEC
-- . .
-- ..........................................................
procedure Purge_Item (Queue : in out PRIORITY_QUEUE;
Object : in ENQUEUED_OBJECT);
--| Purpose
--| Remove all instances of an OBJECT regardless of its priority.
--|
--| Exceptions (none)
--|
--| Notes
--| Works in O (n) time, where n is the NUMBER_OF_ITEMS originally
--| in the QUEUE.
--|
--| Will terminate normally, even if the QUEUE was already EMPTY...
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.PURGE_ITEM . SPEC
-- . .
-- ..........................................................
procedure Purge_Item (Queue : in out PRIORITY_QUEUE;
Object : in ENQUEUED_OBJECT;
Priority : in PRIORITY_VALUE);
--| Purpose
--| Remove all instances of an OBJECT at a given PRIORITY.
--|
--| Exceptions (none)
--|
--| Notes
--| Works in O (n) time, where n is the NUMBER_OF_ITEMS originally
--| in the QUEUE.
--|
--| Will terminate normally, even if the QUEUE was already EMPTY...
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.PURGE_PRIORITY . SPEC
-- . .
-- ..........................................................
procedure Purge_Priority (Queue : in out PRIORITY_QUEUE;
Priority : in PRIORITY_VALUE);
--| Purpose
--| Removes all objects of a given PRIORITY.
--|
--| Exceptions (none)
--|
--| Notes
--| Works in O (n) time, where n is the NUMBER_OF_ITEMS originally
--| in the QUEUE.
--|
--| Will terminate normally, even if the QUEUE was already EMPTY...
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.PURGE_PRIORITY_RANGE . SPEC
-- . .
-- ..........................................................
procedure Purge_Priority_Range (Queue : in out PRIORITY_QUEUE;
From_Priority : in PRIORITY_VALUE;
To_Priority : in PRIORITY_VALUE);
--| Purpose
--| Remove all objects with priorities between FROM_PRIORITY and
--| TO_PRIORITY, inclusive.
--|
--| Exceptions (none)
--|
--| Notes
--| Works in O (n) time, where n is the NUMBER_OF_ITEMS originally
--| in the QUEUE.
--|
--| Will terminate normally, even if the QUEUE was already EMPTY...
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.MERGE . SPEC
-- . .
-- ..........................................................
procedure Merge (Target_Queue : in out PRIORITY_QUEUE;
Source_Queue : in PRIORITY_QUEUE);
--| Purpose
--| Merge two queues. The objects which were in the SOURCE_QUEUE
--| are merged into the TARGET_QUEUE; the SOURCE_QUEUE
--| is left EMPTY.
--|
--| Exceptions (none)
--|
--| Notes
--| Works in O (log n) time, where n is the NUMBER_OF_ITEMS
--| in the newly merged queue.
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.CHANGE_PRIORITY . SPEC
-- . .
-- ..........................................................
procedure Change_Priority (Queue : in out PRIORITY_QUEUE;
Object : in ENQUEUED_OBJECT;
Old_Priority : in PRIORITY_VALUE;
New_Priority : in PRIORITY_VALUE);
--| Purpose
--| Change the priority of an object in a queue.
--|
--| Exceptions
--| Requested_Item_Does_Not_Exist_In_This_Priority_Queue
--| No_Items_Currently_Exist_In_This_Empty_Priority_Queue
--|
--| Notes
--| Works in O (n) time, where n is the NUMBER_OF_ITEMS in the QUEUE.
--|
--| If multiple occurrences of the specified OBJECT and OLD_PRIORITY
--| exist in the QUEUE, the first such occurrence found will be
--| modified, and all others will be left undisturbed.
--|
--| If no occurrences of the specified OBJECT and OLD_PRIORITY exist
--| in the QUEUE, and the QUEUE is not EMPTY, raises
--| Requested_Item_Does_Not_Exist_In_This_Priority_Queue.
--|
--| If the QUEUE is EMPTY, raises
--| No_Items_Currently_Exist_In_This_Empty_Priority_Queue.
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.EMPTY . SPEC
-- . .
-- ..........................................................
function Empty (Queue : in PRIORITY_QUEUE) return BOOLEAN;
--| Purpose
--| Determine if a queue is empty.
--|
--| Exceptions (none)
--|
--| Notes
--| Works in O (1) time.
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.NUMBER_OF_ITEMS . SPEC
-- . .
-- ..........................................................
function Number_of_Items (Queue : in PRIORITY_QUEUE)
return NATURAL;
--| Purpose
--| Determines the number of items in a queue.
--|
--| Exceptions (none)
--|
--| Notes
--| Works in O (n) time, where n is the NUMBER_OF_ITEMS in the QUEUE.
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.ASSIGN . SPEC
-- . .
-- ..........................................................
procedure Assign (Target_Object : in out PRIORITY_QUEUE;
Source_Object : in PRIORITY_QUEUE);
--| Purpose
--| Assign one queue to another, replacing the TARGET_OBJECT.
--|
--| Exceptions (none)
--|
--| Notes
--| Works in O (n) time, where n is the maximum of the
--| NUMBER_OF_ITEMS to be destroyed in the TARGET_OBJECT
--| and the NUMBER_OF_ITEMS in the SOURCE_OBJECT.
-- ..........................................................
-- . .
-- . PRIORITIZED_QUEUE.DESTROY . SPEC
-- . .
-- ..........................................................
procedure Destroy (Targeted_Object : in out PRIORITY_QUEUE);
--| Purpose
--| Destroy a queue, freeing its contents.
--|
--| Exceptions (none)
--|
--| Notes
--| Works in O (n) time, where n is the NUMBER_OF_ITEMS in the QUEUE.
private
type PRIORITY_QUEUE_NODE;
type PRIORITY_QUEUE is access PRIORITY_QUEUE_NODE;
end PRIORITIZED_QUEUE;
--::::::::::
--qsort.spc
--::::::::::
-- ....................................................
-- . .
-- . QSORT . SPEC
-- . .
-- ....................................................
generic
type ITEM is private;
type INDEX is (<>);
type ROW is array (INDEX range <>) of ITEM;
with function "<" (X, Y : ITEM) return BOOLEAN is <>;
procedure Qsort (A : in out ROW);
--| Purpose
--| Sort the one-dimensional array A using the Quick Sort
--| algorithm.
--|
--| Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: John Anderson, TI
--::::::::::
--random.spc
--::::::::::
-- ********************************************************
-- * *
-- * RANDOM * SPEC
-- * *
-- ********************************************************
package Random is
--| Purpose
--| Random.Number returns a pseudo-random number in 0.0 .. 1.0.
--|
--| Initialization Exceptions (none)
--| Notes
--| Uses 16-bit integers, so should be quite portable.
--| Not all MIL-HDBK-1804 PDL annotations are
--| used in this package due to its simplicity.
--|
--| Modifications
--| Original Work: Bill Whitaker
--| Later Mods by: Richard Conn, Ron Bell
-- ......................................................
-- . .
-- . RANDOM.NUMBER . SPEC
-- . .
-- ......................................................
function Number return FLOAT;
end Random;
--::::::::::
--scanners.spc
--::::::::::
-- **************************************************
-- * *
-- * Scanners * SPEC
-- * *
-- **************************************************
package Scanners is
--| Purpose
--| This package is used to break strings into tokens in a
--| very simple but efficient manner. For maximum efficiency,
--| the scanner type is not private so that it can be used
--| directly. The following conventions are adopted to allow
--| the Ada string handling primitives to be used to maximum
--| advantage:
--|
--| 1. Strings are never copied. The scanner type contains
--| First and Last components so that slices may be used
--| to obtain the desired tokens (substrings).
--|
--| 2. The scanner type does not include a copy of the
--| string being scanned, also to avoid copying strings.
--|
--| 3. The Length component of a scanner is always set to the
--| length of the item scanned. If it is zero it means
--| that no such item was found, either because it wasn't
--| there or because the scanner is exhausted. The is_Empty
--| operation may be used to determint if a scanner is
--| exhausted (usually before attempting to scan something).
--|
--| 4. All operations have well defined behavior for any
--| consistent input. There are no exceptions declared in
--| this package or raised directly by the operations in
--| the package.
--|
--| Initialization Exceptions (none)
--|
--| Notes
--| Not all MIL-HDBK-1804 PDL annotations are
--| used in this package due to its simplicity.
--| No exceptions are raised by this package.
--|
--| Modifications
--| Author: Bill Toscano and Michael Gordon, Intermetrics
-- Types:
type SCANNER_TYPE is record
Index : NATURAL; -- Index of next char to be scanned
Max_Index : NATURAL; -- Index of last scannable char
First : NATURAL; -- Index of 1st char of the result of a scan
Last : NATURAL; -- Index of last char of the result of a scan
Length : NATURAL; -- Length of the item scanned
end record;
-- Constructors:
-- ...............................................
-- . .
-- . Scanners.Start_Scanner . SPEC
-- . .
-- ...............................................
procedure Start_Scanner (
Scanner : in out SCANNER_TYPE;
S : in STRING;
Last : in NATURAL);
--| Purpose
--| Initialize Scanner for scanning S from S'FIRST to Last.
--| S and Last are typically obtained by calling
--| Text_IO.Get_Line.
-- ...............................................
-- . .
-- . Scanners.Is_Empty . SPEC
-- . .
-- ...............................................
function Is_Empty (Scanner: in SCANNER_TYPE)
return BOOLEAN;
pragma inline(is_Empty);
--| Purpose
--| Return True iff Scanner.Index > Scanner.Max_Index.
--| Return TRUE iff there are more characters to scan.
-- ...............................................
-- . .
-- . Scanners.Is_Alpha . SPEC
-- . .
-- ...............................................
function Is_Alpha (Scanner : in SCANNER_TYPE;
S : in STRING)
return BOOLEAN;
pragma inline(is_Alpha);
--| Purpose
--| Return True iff S(Scanner.Index) is an alphabetic character.
-- ...............................................
-- . .
-- . Scanners.Is_Alpha . SPEC
-- . .
-- ...............................................
function Is_Digit (Scanner : in SCANNER_TYPE;
S : in string)
return BOOLEAN;
pragma inline(is_Digit);
--| Purpose
--| Return True iff S(Scanner.Index) is a decimal digit.
-- ...............................................
-- . .
-- . Scanners.Is_Sign . SPEC
-- . .
-- ...............................................
function Is_Sign (Scanner : in SCANNER_TYPE;
S : in STRING)
return BOOLEAN;
pragma inline(is_Sign);
--| Purpose
--| Return True iff S(Scanner.Index) is '+' or '-'
-- ...............................................
-- . .
-- . Scanners.Is_Digit_or_Sign . SPEC
-- . .
-- ...............................................
function Is_Digit_or_Sign (Scanner : in SCANNER_TYPE;
S : in string)
return BOOLEAN;
pragma inline(is_Digit_or_Sign);
--| Purpose
--| Return True iff S(Scanner.Index) is '+', '-', or a decimal digit.
-- ...............................................
-- . .
-- . Scanners.Skip_Blanks . SPEC
-- . .
-- ...............................................
procedure Skip_Blanks (Scanner : in out SCANNER_TYPE;
S : in STRING);
--| Purpose
--| Increment Scanner.Index until S(Scanner.Index) is
--| neither a blank nor a tab character, or until it is
--| greater than Scanner.Max_Index.
-- ...............................................
-- . .
-- . Scanners.Trim_Blanks . SPEC
-- . .
-- ...............................................
procedure Trim_Blanks (Scanner : in out SCANNER_TYPE;
S : in STRING);
--| Purpose
--| Adjust Scanner.First and Scanner.Last such that
--| S(Scanner.First..Scanner.Last) contains neither leading
--| nor trailing blanks or tabs. Scanner.Length is adjusted
--| accordingly. This is useful to remove blanks after a
--| call to Scan_Delimited, Scan_Quoted, Scan_Until, etc.
-- ...............................................
-- . .
-- . Scanners.Scan_Until . SPEC
-- . .
-- ...............................................
procedure Scan_Until (Scanner : in out SCANNER_TYPE;
S : in STRING;
C : in CHARACTER);
--| Purpose
--| Scan in string S starting at Scanner.Index until the
--| character C is encountered or the string ends. On
--| return, if Scanner.Length > 0 then
--| S(Scanner.First..Scanner.Last) contains the characters that
--| appeared before C and Scanner(Index) = C. If C was
--| not found, then the scanner is not affected except to
--| set Scanner.Length to 0.
-- ...............................................
-- . .
-- . Scanners.Scan_Word . SPEC
-- . .
-- ...............................................
procedure Scan_Word (Scanner : in out SCANNER_TYPE;
S : in STRING);
--| Purpose
--| Scan in string S for a sequence of non-blank characters,
--| starting at Scanner.Index. On return, if
--| Scanner.Length > 0 then S(Scanner.First..Scanner.Last)
--| is a word and Scanner.Index is just past the end of the
--| word (Scanner.Last+1), ready to scan the next item.
-- ...............................................
-- . .
-- . Scanners.Scan_Number . SPEC
-- . .
-- ...............................................
procedure Scan_Number (Scanner : in out SCANNER_TYPE;
S : in STRING);
--| Purpose
--| Scan in string S for a sequence of numeric characters,
--| optionally preceeded by a sign (+/-), starting at
--| Scanner.Index. On return, if Scanner.Length > 0 then
--| S(Scanner.First..Scanner.Last) is a number and
--| Scanner.Index is just past the end of the number
--| (Scanner.Last+1), ready to scan the next item.
-- ...............................................
-- . .
-- . Scanners.Scan_Delimited . SPEC
-- . .
-- ...............................................
procedure Scan_Delimited (Scanner : in out SCANNER_TYPE;
S : in STRING);
--| Purpose
--| The character S(Scanner.Index) is considered a "quote".
--| Scanner.First is set to the Scanner.Index+1, and
--| Scanner.Index is incremented until another "quote"
--| is encountered or the end of the string is reached.
--| On return, Scanner.Last is the index of the closing
--| "quote" or the last character in S if no closing "quote"
--| was found.
-- ...............................................
-- . .
-- . Scanners.Scan_Quoted . SPEC
-- . .
-- ...............................................
procedure Scan_Quoted (Scanner : in out SCANNER_TYPE;
S : in out STRING);
--| Purpose
--| The character S(Scanner.Index) is considered a "quote".
--| The string S is scanned for a closing "quote". During
--| the scan, two quotes in a row are replaced by a single
--| quote. On return, Scanner.First is the first character
--| of the quoted string, and Scanner.Last is the last
--| character. (The outermost quotes are not included.)
--| Scanner.Index is the first character after the
--| closing quote, Scanner.Length is the number of characters
--| in the quoted string. Note that the string being scanned
--| (S) is modified by this routine (to remove the extra quotes,
--| if any).
end Scanners;
--::::::::::
--search.spc
--::::::::::
-- *****************************************************
-- * *
-- * SEARCH_UTILITIES * SPEC
-- * *
-- *****************************************************
with System;
generic
type COMPONENT_TYPE is limited private; -- type of component to search for
type INDEX_TYPE is (<>); -- type of array index
type ARRAY_TYPE is array (INDEX_TYPE range <>) of COMPONENT_TYPE;
with function "<"(Left, Right : in COMPONENT_TYPE) return BOOLEAN is <>;
with function "="(Left, Right : in COMPONENT_TYPE) return BOOLEAN is <>;
package Search_Utilities is
--| Purpose
--| Search_Utilities is a generic searching package. The Search subprograms
--| will search a one dimensional array of any data type
--| indexed by discrete type components.
--|
--| Note that the component type of the array is not restricted to simple
--| types. An array of records or allocators can be searched. If the
--| component type is a record or allocator, then the generic formal
--| subprogram parameter "<" below must be specified as a selector
--| function.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Geoff Mendal, Stanford University
type DATA_ORDER_TYPE is (ORDERED, NOT_ORDERED);
-- This type should be used to specify how the data is
-- ordered. The default is Not_Ordered. However, significant CPU time
-- can be saved if the data is ordered and the default, Not_Ordered,
-- is overridden.
--
-- If the data are ordered, then if two or more components in the array
-- can match the search component provided, then the component location
-- returned by Search should be thought of as an arbitrary selection
-- from amongst those possible match-components.
--
-- If the data are not ordered, then if two or more components in the
-- array can match the search component provided, then the component
-- location returned by Search will be the one closest to
-- Search_Array'FIRST.
type PERFORMANCE_INSTRUMENTATION_TYPE is range -1 .. System.Max_Int;
-- This type declaration should be used to specify the
-- instrumentation analysis data that can be returned by the
-- Search procedure below. -1 is only returned if an overflow in
-- calculations has occurred. The Search subprograms will not terminate
-- if an overflow in instrumentation analysis data calculations has
-- occurred.
-- ....................................................
-- . .
-- . SEARCH_UTILITIES.VERSION . SPEC
-- . .
-- ....................................................
function Version return STRING;
--| Purpose
--| Returns the version number of this package.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . SEARCH_UTILITIES.SEARCH . SPEC
-- . .
-- ....................................................
procedure Search (
Component : in COMPONENT_TYPE;
Search_Array : in ARRAY_TYPE;
Location_Found : out INDEX_TYPE;
Component_Found : out BOOLEAN;
Number_of_Comparisons : out PERFORMANCE_INSTRUMENTATION_TYPE;
Order_Strategy : in DATA_ORDER_TYPE := NOT_ORDERED;
No_Match_Index : in INDEX_TYPE := INDEX_TYPE'LAST);
--| Purpose
--| This procedure will search a one dimensional array of
--| components. It can search an ordered or unordered array. If
--| an ordered array is specified, it defaults to an ascending
--| order (which can be overridden by the user). The array components
--| must only support equality, inequality, and assignment (private
--| types). The array indices can be of any discrete type. The number
--| of comparisons can also be returned.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . SEARCH_UTILITIES.SEARCH . SPEC
-- . .
-- ....................................................
procedure Search (
Component : in COMPONENT_TYPE;
Search_Array : in ARRAY_TYPE;
Location_Found : out INDEX_TYPE;
Component_Found : out BOOLEAN;
Order_Strategy : in DATA_ORDER_TYPE := NOT_ORDERED;
No_Match_Index : in INDEX_TYPE := INDEX_TYPE'LAST);
--| Purpose
--| This overloading of procedure Search should be used when
--| no instrumentation analysis data are required.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . SEARCH_UTILITIES.SEARCH . SPEC
-- . .
-- ....................................................
function Search (
Component : in COMPONENT_TYPE;
Search_Array : in ARRAY_TYPE;
Order_Strategy : in DATA_ORDER_TYPE := NOT_ORDERED)
return BOOLEAN;
--| Purpose
--| This overloading of function Search should be used when
--| the user only wants to know if the component exists or not.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . SEARCH_UTILITIES.SEARCH . SPEC
-- . .
-- ....................................................
function Search (
Component : in COMPONENT_TYPE;
Search_Array : in ARRAY_TYPE;
Order_Strategy : in DATA_ORDER_TYPE := NOT_ORDERED;
No_Match_Index : in INDEX_TYPE := INDEX_TYPE'LAST)
return INDEX_TYPE;
--| Purpose
--| This overloading of function Search should be used when
--| the component is definitely known to exist and only the location
--| is required. (Note that No_Match_Index may be used to return a
--| no match index value... but this won't work in all cases.)
--|
--| Exceptions (none)
--| Notes (none)
end Search_Utilities;
--::::::::::
--slist.spc
--::::::::::
-- *****************************************************************
-- * *
-- * SINGLY_LINKED_LIST * SPEC
-- * *
-- *****************************************************************
generic
type LIST_ELEMENT is private;
package Singly_Linked_List is
--| Purpose
--| This package provides an abstraction for a singly linked list.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Richard Conn
-- Types
type LIST_TYPE is limited private;
-- Exceptions
End_Error : exception;
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.EMPTY . SPEC
-- . .
-- .............................................................
function Empty (List : LIST_TYPE) return BOOLEAN;
--| Purpose
--| Indicates whether the list contains any elements.
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.NULL_NODE . SPEC
-- . .
-- .............................................................
function Null_Node (List : LIST_TYPE) return BOOLEAN;
--| Purpose
--| Indicates whether the "current pointer" references an element
--| in the list.
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.HEAD_NODE . SPEC
-- . .
-- .............................................................
function Head_Node (List : LIST_TYPE) return BOOLEAN;
--| Purpose
--| Indicates whether the "current pointer" references the head
--| of the list.
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.TAIL_NODE . SPEC
-- . .
-- .............................................................
function Tail_Node (List : LIST_TYPE) return BOOLEAN;
--| Purpose
--| Indicates whether the "current pointer" references the tail
--| of the list.
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.CURRENT_ELEMENT . SPEC
-- . .
-- .............................................................
function Current_Element (List : LIST_TYPE) return LIST_ELEMENT;
--| Purpose
--| Returns the value of the element referenced by the "current pointer".
--| Raises End_Error if Null_Node(List) = True.
--|
--| Exceptions
--| End_Error
--|
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.FIRST . SPEC
-- . .
-- .............................................................
procedure First (List : in out LIST_TYPE);
--| Purpose
--| Positions the "current pointer" at the head of the list
--| (even if the list is empty).
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.NEXT . SPEC
-- . .
-- .............................................................
procedure Next (List : in out LIST_TYPE);
--| Purpose
--| Positions the "current pointer" at the next element in the list.
--| After the last element in the list, Null_Node(List) becomes True.
--| Raises End_Error if Null_Node(List) = True.
--|
--| Exceptions
--| End_Error
--|
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.INSERT_AFTER . SPEC
-- . .
-- .............................................................
procedure Insert_After (List : in out LIST_TYPE;
Element : LIST_ELEMENT);
--| Purpose
--| Inserts an element after the "current pointer".
--| If Null_Node(List) = True the element is appended after
--| the tail element.
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.INSERT_BEFORE . SPEC
-- . .
-- .............................................................
procedure Insert_Before (List : in out LIST_TYPE;
Element : LIST_ELEMENT);
--| Purpose
--| Inserts an element before the "current pointer".
--| If Null_Node(List) = True the element is prepended before
--| the head element.
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.DELETE_ELEMENT . SPEC
-- . .
-- .............................................................
procedure Delete_Element (List : in out LIST_TYPE);
--| Purpose
--| Deletes the element referenced by the "current pointer" from the list.
--| Upon deletion, the "current pointer" references the element after the
--| deleted element.
--| Raises End_Error if Null_Node(List) = True.
--|
--| Exceptions
--| End_Error
--|
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.MODIFY . SPEC
-- . .
-- .............................................................
generic
with procedure Transformation (Element : in out LIST_ELEMENT);
procedure Modify (List : LIST_TYPE);
--| Purpose
--| Permits modification of the element referenced by the "current pointer"
--| where the modification doesn't require external values (e.g.
--| incrementing a field of the element).
--| Raises End_Error if Null_Node(List) = True.
--|
--| Exceptions
--| End_Error
--|
--| Notes (none)
-- .............................................................
-- . .
-- . SINGLY_LINKED_LIST.UPDATE . SPEC
-- . .
-- .............................................................
generic
type UPDATE_INFORMATION is private;
with procedure Transformation (Element : in out LIST_ELEMENT;
Information : UPDATE_INFORMATION);
procedure Update (List : LIST_TYPE;
Information : UPDATE_INFORMATION);
--| Purpose
--| Permits modification of the element referenced by the "current pointer"
--| where the modification requires external values (e.g. assigning a value
--| to a field of the element).
--| Raises End_Error if Null_Node(List) = True.
--|
--| Exceptions
--| End_Error
--|
--| Notes (none)
-- Pragmas
pragma Inline (Empty, Null_Node, Head_Node, Tail_Node, Current_Element);
pragma Inline (Modify, Update);
private
type NODE;
type NODE_ACCESS is access NODE;
type NODE is
record
Element : LIST_ELEMENT;
Next : NODE_ACCESS;
end record;
type LIST_TYPE is
record
Head : NODE_ACCESS;
Tail : NODE_ACCESS;
Previous : NODE_ACCESS;
Current : NODE_ACCESS;
end record;
end Singly_Linked_List;
--::::::::::
--sort.spc
--::::::::::
-- *****************************************************
-- * *
-- * SORT_UTILITIES * SPEC
-- * *
-- *****************************************************
with System; -- predefined package SYSTEM
generic
type COMPONENT_TYPE is private; -- type of the data components
type INDEX_TYPE is (<>); -- type of array index
type ARRAY_TYPE is array (INDEX_TYPE range <>) of COMPONENT_TYPE;
with function "<" (Left,Right : in COMPONENT_TYPE) return BOOLEAN is <>;
with function Equal (Left,Right : in COMPONENT_TYPE) return BOOLEAN is "=";
package Sort_Utilities is
--| Purpose
--| Sort_Utilities is a generic sorting package. The Sort subprograms
--| will sort a one dimensional array of any component type that supports
--| assignment, equality, and inequality (private types) indexed by
--| discrete type components. The default linear order is ascending order
--| but may be overridden by the user. The default sort algorithm,
--| Quicksort (non-recursive), may also be overridden.
--|
--| Note that the component type can be a record type. The Sort subprograms
--| are not restricted to simple data types. If records are to be sorted,
--| then the formal generic subprogram parameter "<" must be
--| specified with by a linear order, e.g., a function provided
--| as an actual generic subprogram parameter at instantiation.
--|
--| Note that the component type can be an access type (which can
--| point to other objects, improving sort efficiency). If access types
--| are to be sorted, then the formal generic subprogram parameter "<"
--| must be specified by a linear order (see example #3 below).
--| Since access types can be sorted, the Sort routine below can be
--| used to sort limited types and unconstrained types (designated by
--| an access type).
--|
--| For data in which equality does not truly apply (i.e., real types)
--| one can use the Equal function to specify an equality operation.
--| Hence, one can decide that two numbers are "close enough" to be
--| equal (see example #4 below).
--|
--| The number of comparisons and exchanges made to sort the array
--| can be returned. These numbers should give some indication on how
--| much work was actually performed by the sorting algorithms. These
--| numbers can also be used to compare the relative efficiency
--| of the sorting algorithms.
--|
--| This package can be used to sort data on external devices. The user
--| should use this package to sort a subset of the external data, then
--| use a merge operation on all sorted subsets. For example, if the
--| system can only hold 1000 components in RAM, but you need to sort
--| 3000 components, bring in components #1-1000 and sort them using this
--| routine, and then write them to a file. Next do the same with
--| components #1001-2000, and finally with components #2001-3000. Now
--| merge the three sorted files using a merge package.
--|
--| One of the Sort subprograms is a function which can be used to sort
--| an array and test it against another in an inline expression. This
--| can be useful when comparing the contents of two arrays which may be
--| equal, but not at the identical indices. This will be most useful for
--| comparing the equality of sets implemented as arrays (see example #5
--| below).
--|
--| Other Sort subprograms allow the user to maintain the original state
--| of the array by returning a new array that is sorted. These subprograms
--| will be useful in cases where sorting is required, but the original
--| (unsorted) data must be preserved.
--|
--| Design of this package has been documented in the IEEE Computer
--| Society Second International Conference on Ada Applications and
--| Environments proceedings. Contact the IEEE or the author for a copy
--| of the paper. This paper is forthcoming in a special issue of IEEE
--| Software also.
--|
--| Initialization Exceptions (none)
--|
--| Notes
--| See the explanation below for details on the different
--| sort algorithms available and their respective merits.
--| There are also examples at the end of this specification
--| on the use of this package.
--|
--| Modifications
--| Author: Goeff Mendal, Stanford University
type SORT_ALGORITHM_TYPE is (Quicksort, Recursive_Quicksort, Bsort,
Bubble_Sort, Bubble_Sort_with_Quick_Exit, Selection_Sort, Heapsort,
Insertion_Sort, Merge_Sort);
-- Users can specify the type of sorting algorithm they want by
-- specifying an enumeration literal from the type above. The default
-- algorithm, Quicksort (non-recursive), generally performs best.
--
-- One note about stability of the algorithms: only the Bubble Sorts
-- and Insertion Sort are stable algorithms. Thus, they are the
-- only algorithms that preserve the ordering of equal components
-- without use of a selector function. In all cases, a selector
-- function may be specified to introduce stability into the
-- sorting algorithms (see example #3 below).
--
-- Quicksort: O(NlogN). Is most efficient when used with large, unsorted
-- arrays. Uses an explicit stack to maintain state and
-- partitions. Instable. This is the default algorithm.
-- Recursive_Quicksort: O(NlogN). Is most efficient when used with large,
-- unsorted arrays. Recursive nature may introduce significant
-- memory overhead for very large arrays. Instable.
-- Bsort: O(NlogN). Is most efficient when used with large arrays
-- that are already sorted, partially sorted, or sorted in
-- reverse. Recursive. Instable.
-- Bubble_Sort: O(N**2). Is most efficient when used with small
-- arrays that are almost already sorted. Non-recursive.
-- Brute force. Low memory requirements. Stable.
-- Bubble_Sort_with_Quick_Exit: O(N**2). Is most efficient when
-- used with small arrays that are almost already sorted.
-- Non-recursive. Same as bubble sort above except brute
-- force is limited. Stable.
-- Selection_Sort: O(N**2). Is most efficient when used with
-- small arrays in which the Component_Type is a
-- record type. Non-recursive. Brute force. Instable.
-- Heapsort: O(NlogN). Is most efficient when used with
-- large, unsorted arrays. Non-recursive. Very low
-- memory requirements. Instable.
-- Insertion_Sort: O(N**2). Is most efficient when used with
-- small arrays that are almost already sorted. Non-
-- recursive. Brute force. Stable.
-- Merge_Sort: O(NlogN). Is most efficient when used with medium-large
-- arrays. Non-recursive. Instable. Uses an auxiliary array
-- to perform merging.
type PERFORMANCE_INSTRUMENTATION_TYPE is range -1 .. SYSTEM.MAX_INT;
-- This type declaration should be used to specify the
-- instrumentation analysis results that can be returned by the Sort
-- subprograms below. -1 is only returned if an overflow in calculations
-- has occurred. The Sort subprograms will still sort the array if an
-- overflow in instrumentation analysis data calculations
-- occurs.
Sort_Arrays_Length_Mismatch : exception;
-- This exception is raised during execution of the Sort
-- subprograms which take two arrays as parameters. These two arrays
-- must be of the same length.
-- ...................................................
-- . .
-- . SORT_UTILITIES.VERSION . SPEC
-- . .
-- ...................................................
function Version return STRING;
--| Purpose
--| Returns the version number of this package.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . SORT_UTILITIES.SORT . SPEC
-- . .
-- ...................................................
procedure Sort (
Sort_Array : in out ARRAY_TYPE;
Number_of_Comparisons,
Number_of_Exchanges : out PERFORMANCE_INSTRUMENTATION_TYPE;
Sort_Algorithm : in SORT_ALGORITHM_TYPE := Quicksort);
--| Purpose
--| The following procedure will sort a one dimensional array of
--| components. It can sort in ascending/descending order or any
--| user-defined order. It can sort components of any type that
--| support equality, inequality, and assignment (private types).
--| The array indices can be of any discrete type. The number of
--| comparisons and exchanges can also be returned.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . SORT_UTILITIES.SORT . SPEC
-- . .
-- ...................................................
procedure Sort (
Sort_Array : in out ARRAY_TYPE;
Sort_Algorithm : in SORT_ALGORITHM_TYPE := Quicksort);
--| Purpose
--| This overloading of procedure Sort should be specified
--| when no instrumentation analysis data are required.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . SORT_UTILITIES.SORT . SPEC
-- . .
-- ...................................................
procedure Sort (
Unsorted_Array : in ARRAY_TYPE;
Sorted_Array : out ARRAY_TYPE;
Number_of_Comparisons,
Number_of_Exchanges : out PERFORMANCE_INSTRUMENTATION_TYPE;
Sort_Algorithm : in SORT_ALGORITHM_TYPE := Quicksort);
--| Purpose
--| The following overloading of procedure Sort should be used when
--| the original data must be preserved and instrumentation analysis
--| results are required.
--|
--| Exceptions
--| Sort_Arrays_Length_Mismatch is raised if Unsorted_Array
--| and Sorted_Array are not
--| the same length
--|
--| Notes (none)
-- ...................................................
-- . .
-- . SORT_UTILITIES.SORT . SPEC
-- . .
-- ...................................................
procedure Sort (
Unsorted_Array : in ARRAY_TYPE;
Sorted_Array : out ARRAY_TYPE;
Sort_Algorithm : in SORT_ALGORITHM_TYPE := Quicksort);
--| Purpose
--| The following overloading of procedure Sort should be used when
--| the original data must be preserved and no instrumentation analysis
--| results are required.
--|
--| Exceptions
--| Sort_Arrays_Length_Mismatch is raised if Unsorted_Array
--| and Sorted_Array are not
--| the same length
--|
--| Notes (none)
-- ...................................................
-- . .
-- . SORT_UTILITIES.SORT . SPEC
-- . .
-- ...................................................
function Sort (
Sort_Array : in ARRAY_TYPE;
Sort_Algorithm : in SORT_ALGORITHM_TYPE := Quicksort)
return Array_Type;
--| Purpose
--| This overloading of function Sort should be used when
--| sorting is required in an inline expression.
end Sort_Utilities;
--::::::::::
--stringer.spc
--::::::::::
-- *****************************************************************
-- * *
-- * STRING_MANIPULATOR * SPEC
-- * *
-- *****************************************************************
package String_Manipulator is
--| Purpose
--| STRING_MANIPULATOR provides a few routines
--| for storing string values into different
--| sizes of strings.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Richard Conn
-- Exceptions
STRING_OVERFLOW : exception; -- raised by GUARDED_LOAD
-- .............................................................
-- . .
-- . STRING_MANIPULATOR.LOAD . SPEC
-- . .
-- .............................................................
procedure Load (From : in STRING;
To : out STRING;
Fill_Character : in CHARACTER := ' ');
--| Purpose
--| LOAD places the string FROM into the first part of the
--| string TO, filling the rest with FILL_CHARACTER; if the string
--| FROM is longer than the string TO, the string FROM is truncated
--| into TO without warning
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . STRING_MANIPULATOR.LOAD . SPEC
-- . .
-- .............................................................
procedure Load (From : in STRING;
To : out STRING;
Last : out NATURAL;
Fill_Character : in CHARACTER := ' ');
--| Purpose
--| LOAD places the string FROM into the first part of the
--| string TO, filling the rest with FILL_CHARACTER; if the string
--| FROM is longer than the string TO, the string FROM is truncated
--| into TO without warning
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . STRING_MANIPULATOR.GUARDED_LOAD . SPEC
-- . .
-- .............................................................
procedure Guarded_Load (From : in STRING;
To : out STRING;
Fill_Character : in CHARACTER := ' ');
--| Purpose
--| GUARDED_LOAD places the string FROM into the first part of the
--| string TO, filling the rest with FILL_CHARACTER; if the string
--| FROM is longer than the string TO, the exception STRING_OVERFLOW is
--| raised
--|
--| Exceptions
--| STRING_OVERFLOW
--|
--| Notes (none)
-- .............................................................
-- . .
-- . STRING_MANIPULATOR.GUARDED_LOAD . SPEC
-- . .
-- .............................................................
procedure Guarded_Load (From : in STRING;
To : out STRING;
Last : out NATURAL;
Fill_Character : in CHARACTER := ' ');
--| Purpose
--| GUARDED_LOAD places the string FROM into the first part of the
--| string TO, filling the rest with FILL_CHARACTER; if the string
--| FROM is longer than the string TO, the exception STRING_OVERFLOW is
--| raised
--|
--| Exceptions
--| STRING_OVERFLOW
--|
--| Notes (none)
-- .............................................................
-- . .
-- . STRING_MANIPULATOR.FILL . SPEC
-- . .
-- .............................................................
procedure Fill (What : out STRING;
With_Item : in CHARACTER := ' ');
--| Purpose
--| FILL fills the string WHAT with the indicated WITH_ITEM
--|
--| Exceptions (none)
--| Notes (none)
-- .............................................................
-- . .
-- . STRING_MANIPULATOR.IS_FILLED . SPEC
-- . .
-- .............................................................
function Is_Filled (What : in STRING;
With_Item : in CHARACTER := ' ') return BOOLEAN;
--| Purpose
--| IS_FILLED returns TRUE if the string WHAT contains only the
--| character WITH_ITEM; IS_FILLED returns FALSE otherwise
--|
--| Exceptions (none)
--| Notes (none)
end String_Manipulator;
--::::::::::
--testlog.spc
--::::::::::
-- **************************************************
-- * *
-- * Test_Log * SPEC
-- * *
-- **************************************************
package Test_Log is
--| Purpose
--| A Test Log is a log of test activity. Expected and
--| Actual test results can be reported to it via the Compare
--| routines, and Test Log can build a summary report of
--| the test results. It keeps track of the number of
--| tests and the number of errors detected.
--|
--| Test_Log provides a number of Compare routines
--| that compare one value with another and two counters.
--| The Test Counter is incremented each time a Compare
--| routine is called and the Error counter is
--| incremented each time the comparison does not work
--| out.
--|
--| Test_Log performs its operations in one of three modes
--| which may be selected by calling the Set_Mode routine:
--| SILENT all results of calls to Compare are
--| logged internally and no display is
--| generated except when the Report
--| routine is called
--| VERBOSE all results of calls to Compare are
--| displayed on the console
--| REPORT_TO_FILE same as VERBOSE, except the results
--| are written to a file rather than to
--| the console
--|
--| A fourth "mode" is USER_SELECTABLE, which results in a
--| prompt being displayed to the user and the user selecting
--| one of the modes SILENT, VERBOSE, or REPORT_TO_FILE.
--|
--| Initialization Exceptions (none)
--| Notes
--| The Test and Error counters are initially set to
--| zero. They may be reset to zero at any time by
--| calling the Reset procedure.
--| The Test and Error counters are of type NATURAL,
--| so care should be exercised to see that no more
--| tests than NATURAL'LAST are done before a Reset.
--|
--| Modifications
--| 2/27/91 Richard Conn Initial Version and Release
REPORT_FILE_ERROR : exception;
-- raised if output report file cannot be created
Test_Log_File : constant STRING := "testlog.rpt";
-- Name of test log file (see next comment)
type MODE is (SILENT, VERBOSE, REPORT_TO_FILE, USER_SELECTABLE);
-- The Test Log can run silently, displaying a summary report
-- at the end, or verbosely, displaying each comparison as it
-- is done. The REPORT_TO_FILE mode is the same as VERBOSE,
-- but the output is sent to Test_Log_File rather than the
-- console. USER_SELECTABLE causes the user to be prompted at
-- the console and manually select the SILENT, VERBOSE, or
-- REPORT_TO_FILE modes.
type TEST_RESULT is (FAIL, PASS);
-- Values of the result of a test
-- ..................................................
-- . .
-- . Test_Log.Set_Mode . SPEC
-- . .
-- ..................................................
procedure Set_Mode (To : in MODE);
--| Purpose
--| The mode of operation is set to the indicated mode.
--| See the discussion above for a description of the
--| modes.
--|
--| Exceptions (none)
--| Notes
--| If this routine is not called, the default mode
--| is SILENT.
-- ..................................................
-- . .
-- . Test_Log.Set_Test_ID_Field_Width . SPEC
-- . .
-- ..................................................
procedure Set_Test_ID_Field_Width (To : in NATURAL := 10);
--| Purpose
--| Set the length of a test ID to be output (up to 60).
--| Any test ID string shorter than this length will be
--| padded with spaces. Any test ID string longer than
--| this length will be output in full.
--|
--| Exceptions (none)
--| Notes
--| If this routine is not called, the field width is
--| automatically set to the default value.
-- ..................................................
-- . .
-- . Test_Log.Set_String_Field_Width . SPEC
-- . .
-- ..................................................
procedure Set_String_Field_Width (To : in NATURAL := 20);
--| Purpose
--| Set the length of a string to be output (up to 60).
--| Any string shorter than this length will be padded
--| with spaces. Any string longer than this length
--| will be output in full.
--|
--| Exceptions (none)
--| Notes
--| If this routine is not called, the field width is
--| automatically set to the default value.
-- ..................................................
-- . .
-- . Test_Log.Set_Integer_Field_Width . SPEC
-- . .
-- ..................................................
procedure Set_Integer_Field_Width (To : in NATURAL := 20);
--| Purpose
--| Set the length of an integer to be output.
--| If the integer requires more space than this,
--| the necessary space will be taken.
--|
--| Exceptions (none)
--| Notes
--| If this routine is not called, the field width is
--| automatically set to the default value.
-- ..................................................
-- . .
-- . Test_Log.Set_Float_Field_Width . SPEC
-- . .
-- ..................................................
procedure Set_Float_Field_Width
(Before_Decimal : in NATURAL := 2;
After_Decimal : in NATURAL := 5;
In_Exponent : in NATURAL := 4);
--| Purpose
--| Set the length of the fields of a floating point
--| value to be output. If In_Exponent is non-zero,
--| scientific notation is used; if In_Exponent is
--| zero, fixed point notation is used.
--|
--| Exceptions (none)
--| Notes
--| If this routine is not called, the field widths are
--| automatically set to the default values.
-- ..................................................
-- . .
-- . Test_Log.Reset . SPEC
-- . .
-- ..................................................
procedure Reset;
--| Purpose
--| The Reset routine resets the test and error counters.
--| It need not be called the first time this package's
--| routines are used since these counters come up
--| initialized.
--|
--| Exceptions (none)
-- ..................................................
-- . .
-- . Test_Log.Compare . SPEC
-- . .
-- ..................................................
procedure Compare(Test_ID : in STRING;
Expected_Result : in STRING;
Actual_Result : in STRING);
procedure Compare(Test_ID : in STRING;
Expected_Result : in INTEGER;
Actual_Result : in INTEGER);
procedure Compare(Test_ID : in STRING;
Expected_Result : in FLOAT;
Actual_Result : in FLOAT;
Tolerance : in FLOAT);
--| Purpose
--| These routines compare the two values (x1 and x2) for
--| equality (except in the case of F1 and F2, which are
--| compared by abs(F1-F2)<Tolerance). If these values
--| are equal or within tolerance, then only the
--| Test counter is incremented. If these values are
--| not equal or within tolerance, the Test counter and
--| Error counter are incremented and the Test_ID is
--| displayed.
--|
--| If the Mode (see the Set_Mode procedure) is SILENT,
--| the results are not shown. If the Mode is VERBOSE
--| or REPORT_TO_FILE, then the Test_ID, the Expected_Result,
--| the Actual_Result, and the result of the comparison
--| (FAIL or PASS) is written to the console (VERBOSE)
--| or the output file Test_Log_File (REPORT_TO_FILE).
--|
--| Exceptions (none)
-- ..................................................
-- . .
-- . Test_Log.Enter_Test_Result . SPEC
-- . .
-- ..................................................
procedure Enter_Test_Result
(Test_ID : in STRING;
Result : in TEST_RESULT);
--| Purpose
--| This routine enters Result as though a Compare call
--| was made. This is the same as calling one of the
--| Compare routines, but the result of the comparison
--| is the input value to this routine and no comparison
--| is actually done. This is useful when a test does
--| not generate a value as a result, such as when the
--| test expects an exception to be raised.
--|
--| See the Purpose section of the Compare routines
--| for more information.
--|
--| Exceptions (none)
-- ..................................................
-- . .
-- . Test_Log.Error_Count . SPEC
-- . .
-- ..................................................
function Error_Count return NATURAL;
--| Purpose
--| Error_Count returns the value of the Error Counter.
--|
--| Exceptions (none)
-- ..................................................
-- . .
-- . Test_Log.Test_Count . SPEC
-- . .
-- ..................................................
function Test_Count return NATURAL;
--| Purpose
--| Test_Count returns the value of the Test Counter.
--|
--| Exceptions (none)
-- ..................................................
-- . .
-- . Test_Log.Write . SPEC
-- . .
-- ..................................................
procedure Write(Message : in STRING := "");
--| Purpose
--| Write the message to the console followed by a
--| New Line.
--|
--| Exceptions (none)
-- ..................................................
-- . .
-- . Test_Log.Report . SPEC
-- . .
-- ..................................................
procedure Report(Message : in STRING := "");
--| Purpose
--| Print a report showing the values of the Test and
--| Error Counters. If Message is not null, it is
--| printed, indented, before the counter values.
--|
--| Exceptions (none)
-- ..................................................
-- . .
-- . Test_Log.Close . SPEC
-- . .
-- ..................................................
procedure Close;
--| Purpose
--| Close the Test Log. If a Test_Log_File is open,
--| it is closed.
--|
--| Exceptions (none)
end Test_Log;
--::::::::::
--binfile.spc
--::::::::::
-- **************************************************
-- * *
-- * Binary_File * SPEC
-- * *
-- **************************************************
with CS_Parts_Types; -- for BYTE type
use CS_Parts_Types;
package Binary_File is
--| Purpose
--| Binary_File provides a convenient mechanism for accessing
--| binary files, implemented as an abstract data type. The
--| binary file may be read or written one byte at a time.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| 7/15/90 Rick Conn Initial Design and Code
type FILE_TYPE is limited private;
type FILE_MODE is (IN_FILE, OUT_FILE);
type BLOCK is array (INTEGER range <>) of BYTE;
Data_Error, -- full BLOCK could not be read
Device_Error, -- problem with underlying system
End_Error, -- read attempted into end of file
Mode_Error, -- read attempted from output file, etc.
Name_Error, -- invalid file/dir name
Status_Error, -- file already open
Use_Error, -- write to read/only file, others
Unexpected_Error
: exception;
-- ...................................................
-- . .
-- . Binary_File.Create . SPEC
-- . .
-- ...................................................
procedure Create (File : in out FILE_TYPE;
Name : in STRING);
--| Purpose
--| Create a binary file and open it for output.
--|
--| Exceptions
--| Device_Error -- raised if file cannot be created
--| -- due to a hardware error
--| Name_Error -- raised if Name is not a valid file
--| -- or directory reference
--| Status_Error -- raised if file Name is already
--| -- open
--| Use_Error -- raised if file Name exists and is
--| -- read/only
--|
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Open . SPEC
-- . .
-- ...................................................
procedure Open (File : in out FILE_TYPE;
Name : in STRING);
--| Purpose
--| Open an existing binary file for input.
--|
--| Exceptions
--| Device_Error -- raised if file cannot be opened
--| -- due to a hardware error
--| Name_Error -- raised if Name is not a valid file
--| -- or directory reference
--| Status_Error -- raised if file Name is already
--| -- open
--| Use_Error -- raised if file Name is write/only
--|
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Close . SPEC
-- . .
-- ...................................................
procedure Close (File : in out FILE_TYPE);
--| Purpose
--| Close the indicated file.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Reset . SPEC
-- . .
-- ...................................................
procedure Reset (File : in out FILE_TYPE;
Mode : in FILE_MODE := IN_FILE);
--| Purpose
--| Close the indicated file and reopen it (at the
--| beginning) for input or output.
--|
--| Exceptions
--| Device_Error -- raised if file cannot be accessed
--| -- due to a hardware error
--| Name_Error -- raised if Name is not a valid file
--| -- or directory reference
--| Status_Error -- raised if file Name is already
--| -- open
--| Use_Error -- raised if file Name exists and is
--| -- read/only
--|
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Mode . SPEC
-- . .
-- ...................................................
function Mode (File : in FILE_TYPE) return FILE_MODE;
--| Purpose
--| Return the mode (IN_FILE or OUT_FILE) of the
--| indicated File.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Name . SPEC
-- . .
-- ...................................................
function Name (File : in FILE_TYPE) return STRING;
--| Purpose
--| Return the name of the indicated File.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Is_Open . SPEC
-- . .
-- ...................................................
function Is_Open (File : in FILE_TYPE) return BOOLEAN;
--| Purpose
--| Return TRUE iff the indicated File is open.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Is_End . SPEC
-- . .
-- ...................................................
function Is_End (File : in FILE_TYPE) return BOOLEAN;
--| Purpose
--| Return TRUE if the next byte to be returned from
--| the indicated File is beyond the end of the file.
--|
--| Exceptions (none)
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Read . SPEC
-- . .
-- ...................................................
procedure Read (File : in FILE_TYPE;
Item : out BYTE);
--| Purpose
--| Read the next byte from an OPENed File.
--|
--| Exceptions
--| Device_Error -- raised if File cannot be accessed
--| -- due to a hardware error
--| End_Error -- raised if the next byte to be
--| -- returned is beyond the end of
--| -- the File
--| Mode_Error -- raised if File is opened for
--| -- output (mode OUT_FILE)
--| Status_Error -- raised if File has not been
--| -- OPENed
--|
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Read . SPEC
-- . .
-- ...................................................
procedure Read (File : in FILE_TYPE;
Item : out BLOCK);
--| Purpose
--| Read the next block from an OPENed File.
--|
--| Exceptions
--| Data_Error -- raised if a full BLOCK could
--| -- not be read from the file
--| Device_Error -- raised if File cannot be accessed
--| -- due to a hardware error
--| End_Error -- raised if the next byte to be
--| -- returned is beyond the end of
--| -- the File
--| Mode_Error -- raised if File is opened for
--| -- output (mode OUT_FILE)
--| Status_Error -- raised if File has not been
--| -- OPENed
--|
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Write . SPEC
-- . .
-- ...................................................
procedure Write (File : in FILE_TYPE;
Item : in BYTE);
--| Purpose
--| Write the next byte to a CREATEed File.
--|
--| Exceptions
--| Device_Error -- raised if File cannot be accessed
--| -- due to a hardware error
--| Mode_Error -- raised if File is opened for
--| -- input (mode IN_FILE)
--| Status_Error -- raised if File has not been
--| -- CREATEd
--|
--| Notes (none)
-- ...................................................
-- . .
-- . Binary_File.Write . SPEC
-- . .
-- ...................................................
procedure Write (File : in FILE_TYPE;
Item : in BLOCK);
--| Purpose
--| Write the next block to a CREATEed File.
--|
--| Exceptions
--| Device_Error -- raised if File cannot be accessed
--| -- due to a hardware error
--| Mode_Error -- raised if File is opened for
--| -- input (mode IN_FILE)
--| Status_Error -- raised if File has not been
--| -- CREATEd
--|
--| Notes (none)
private
type FILE_OBJECT; -- deferred to body
type FILE_TYPE is access FILE_OBJECT;
end Binary_File;
--::::::::::
--bintree2.spc
--::::::::::
-- ***********************************************
-- * *
-- * BINARYTREES * SPEC
-- * *
-- ***********************************************
with Lists;
generic
type ITEMTYPE is private;
with function "<" (X,Y: in ITEMTYPE) return BOOLEAN;
package BinaryTrees is
--| Purpose
--| This package creates an ordered binary tree. This will allow for
--| quick insertion, and search.
--|
--| The tree is organized such that
--|
--| leftchild < root root < rightchild
--|
--| This means that by doing a left to right search of the tree will can
--| produce the nodes of the tree in ascending order.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Bill Toscano and Michael Gordon, Intermetrics
type TREE is private; -- This is the type exported to represent the
-- tree.
type TREEITER is private; -- This is the type which is used to iterate
-- over the set.
-- .................................................
-- . .
-- . BINARYTREES.CREATE . SPEC
-- . .
-- .................................................
function Create return TREE;
--| Purpose
--| This creates a tree containing no information and no children.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . BINARYTREES.DEPOSIT . SPEC
-- . .
-- .................................................
procedure Deposit (I : in ITEMTYPE; S : in TREE);
--| Purpose
--| This changes the information stored at the root of the tree S.
--| It deposits the information I in the root of S.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . BINARYTREES.DESTROYTREE . SPEC
-- . .
-- .................................................
procedure DestroyTree (T :in out TREE);
--| Purpose
--| Destroys a tree and returns the space which it is occupying.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . BINARYTREES.INSERTNODE . SPEC
-- . .
-- .................................................
Procedure Insertnode(N : In Out ITEMTYPE;
T : In Out TREE;
Root : Out TREE;
Exists : out BOOLEAN);
--| Purpose
--| This adds the node N to the tree T inserting in the proper position.
--| Root is the root of the subtree which Node N heads (the position
--| of Node N in T).
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . BINARYTREES.MAKETREEITER . SPEC
-- . .
-- .................................................
function MakeTreeIter (T : in TREE) return TREEITER;
--| Purpose
--| Sets a variable to a position in the tree where the iteration is
--| to begin. In this case, the position is a pointer to the deepest
--| leftmost leaf in the tree.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . BINARYTREES.MORE . SPEC
-- . .
-- .................................................
function More (I : in TREEITER) return BOOLEAN;
--| Purpose
--| Returns TRUE iff there are more elements in the tree
--| over which to iterate.
--|
--| Exceptions (none)
--| Notes (none)
-- .................................................
-- . .
-- . BINARYTREES.NEXT . SPEC
-- . .
-- .................................................
procedure Next (I : in out TREEITER;
Info : out ITEMTYPE);
--| Purpose
--| This is the iterator operation. Given an Iter in the Tree, it
--| returns the item Iter points to and updates the Iter. If Iter
--| is at the end of the Tree, More will indicate such.
--|
--| Exceptions (none)
--| Notes (none)
private
type NODE;
type TREE is access NODE;
type NODE is
record
Info : ITEMTYPE;
LeftChild : TREE;
RightChild : TREE;
end record;
package NodeOrder is new Lists (TREE);
type TREEITER is
record
NodeList : NodeOrder.LIST;
State : NodeOrder.LISTITER;
end record;
end BinaryTrees;
--::::::::::
--hashmap.spc
--::::::::::
-- ******************************************************
-- * *
-- * Hashed_Mapping_PKG * SPEC
-- * *
-- ******************************************************
with lists; -- Lists used in implementation. (private)
pragma elaborate(lists);
generic
type KEY_TYPE is private;
with function Equal (K1, K2: KEY_TYPE) return BOOLEAN is "=";
type BUCKET_RANGE is range <>;
-- Defines the number of hash buckets, one for each member
-- of BUCKET_RANGE.
with function Hash (K: KEY_TYPE) return BUCKET_RANGE;
-- Required property: equal(e1, e2) => hash(e1) = hash(e2).
-- Best results if hash produces a uniform distribution
-- over BUCKET_RANGE.
type VALUE_TYPE is private;
package Hashed_Mapping_PKG is
--| Purpose
--| This package provides a mapping from one arbitrary type,
--| KEY_TYPE, to another arbitrary type, VALUE_TYPE. These
--| types are generic formals to the package, along with an
--| equality relation on KEY_TYPE, an integer subtype that
--| determines the number of hash buckets, and a hashing
--| function on KEY_TYPE that maps to that integer subtype.
--|
--| For the purpose of specifying the operations in this
--| package, we will view a mapping as a set of bindings,
--| or key/value pairs. This allows the use of set notation
--| in description.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Ron Kownacki, Intermetrics
type MAPPING is private;
No_More: exception;
-- Raised on incorrect use of an iterator.
Uninitialized_Mapping: exception;
-- Raised on use of an unitialized MAPPING by most operations.
Already_Bound: exception;
-- Raised on attempt to rebind a key that is currently bound.
Not_Bound: exception;
-- Raised when a key that is expected to be bound is unbound.
type KEYS_ITER is private; -- Bound keys in arbitrary order.
type VALUES_ITER is private; -- Bound values in arbitrary order.
type BINDINGS_ITER is private; -- Key,value pairs in arbitrary order
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Create . SPEC
-- . .
-- .......................................................
function Create return MAPPING;
--| Purpose
--| Return {}.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Bind . SPEC
-- . .
-- .......................................................
procedure Bind (Map: in out MAPPING;
Key: in KEY_TYPE;
Value: in VALUE_TYPE);
--| Purpose
--| Insert the binding, <key, value>, into map. Raises
--| already_bound iff a pair, <k', v'>, where equal(key, k'),
--| is in map. Raises Uninitialized_Mapping iff map has
--| not been initialized.
--|
--| Exceptions
--| Already_Bound
--| Uninitialized_Mapping
--|
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Unbind . SPEC
-- . .
-- .......................................................
procedure Unbind (Map: in out MAPPING;
Key: in KEY_TYPE);
--| Purpose
--| If <k, v>, where equal(key, k), is in map, then removes
--| <k, v> from map. Raises not_bound if no such pair exists.
--| Raises Uninitialized_Mapping iff map has not been initialized.
--|
--| Exceptions
--| Not_Bound
--| Uninitialized_Mapping
--|
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Copy . SPEC
-- . .
-- .......................................................
function Copy (Map: MAPPING) return MAPPING;
--| Purpose
--| Returns a copy of map. Subsequent changes to map will not be
--| visible through applying operations to the copy of map.
--| Assignment or parameter passing without copying will result
--| in a single MAPPING value being shared among MAPPING objects.
--| Raises Uninitialized_Mapping iff map has not been initialized.
--| The assignment operation is used to transfer the values of the
--| KEY_TYPE and VALUE_TYPE type COMPONENTs of map; consequently,
--| changes in the values of these types may be observable through
--| both MAPPINGs if these are access types, or if they contain
--| COMPONENTs of an access type.
--|
--| Exceptions
--| Uninitialized_Mapping
--|
--| Notes (none)
-- Query Operations:
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Is_Empty . SPEC
-- . .
-- .......................................................
function Is_Empty (Map: MAPPING) return BOOLEAN;
--| Purpose
--| Return map = {}.
--| Raises Uninitialized_Mapping iff map has not been
--| initialized.
--|
--| Exceptions
--| Uninitialized_Mapping
--|
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Size . SPEC
-- . .
-- .......................................................
function Size (Map: MAPPING) return NATURAL;
--| Purpose
--| Return |map|, the number of bindings in map.
--| Raises Uninitialized_Mapping iff map has not been
--| initialized.
--|
--| Exceptions
--| Uninitialized_Mapping
--|
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Is_Bound . SPEC
-- . .
-- .......................................................
function Is_Bound (Map: MAPPING; Key: KEY_TYPE) return BOOLEAN;
--| Purpose
--| Return true iff equal(key, k) for some <k, v> in map.
--| Raises Uninitialized_Mapping iff map has not been
--| initialized.
--|
--| Exceptions
--| Uninitialized_Mapping
--|
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Fetch . SPEC
-- . .
-- .......................................................
function Fetch (Map: MAPPING; Key: KEY_TYPE) return VALUE_TYPE;
--| Purpose
--| If <k, v>, where equal(key, k), is in map, then return v.
--| Raises not_bound if no such <k, v> exists.
--| Raises Uninitialized_Mapping iff map has not been
--| initialized.
--|
--| Exceptions
--| Not_Bound
--| Uninitialized_Mapping
--|
--| Notes (none)
-- Iterators:
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Make_Keys_Iter . SPEC
-- . .
-- .......................................................
function Make_Keys_Iter (Map: MAPPING) return KEYS_ITER;
--| Purpose
--| Create and return a keys iterator based on map. This
--| object can then be used in conjunction with the more
--| function and the next procedure to iterate over all keys
--| that are bound in map. Raises Uninitialized_Mapping iff
--| map has not been initialized.
--|
--| Exceptions
--| Uninitialized_Mapping
--|
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.More . SPEC
-- . .
-- .......................................................
function More (Iter: KEYS_ITER) return BOOLEAN;
--| Purpose
--| Return true iff the keys iterator has not been exhausted.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Next . SPEC
-- . .
-- .......................................................
procedure Next (Iter: in out KEYS_ITER; Key: out KEY_TYPE);
--| Purpose
--| Let iter be based on the MAPPING, map. Successive calls
--| of next will return the bound keys of map in some
--| arbitrary order. After all bound keys have been returned,
--| then the procedure will raise no_more.
--|
--| Exceptions
--| No_More
--|
--| Notes
--| Map must not be changed between the invocations of
--| Make_Keys_Iterator (Map) and Next.
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Make_Values_Iter . SPEC
-- . .
-- .......................................................
function Make_Values_Iter (Map: MAPPING) return VALUES_ITER;
--| Purpose
--| Create and return a values iterator based on map. This
--| object can then be used in conjunction with the more
--| function and the next procedure to iterate over all values
--| that are bound to keys in map.
--| Raises Uninitialized_Mapping iff map has not been
--| initialized.
--|
--| Exceptions
--| Uninitialized_Mapping
--|
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.More . SPEC
-- . .
-- .......................................................
function More (Iter: VALUES_ITER) return BOOLEAN;
--| Purpose
--| Return true iff the values iterator has not been exhausted.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Next . SPEC
-- . .
-- .......................................................
procedure Next (Iter: in out VALUES_ITER; Val: out VALUE_TYPE);
--| Purpose
--| Let iter be based on the MAPPING, map. Successive calls
--| of next will return the bound values of map in some
--| arbitrary order. After all bound values have been returned,
--| then the procedure will raise no_more.
--|
--| Exceptions
--| No_More
--|
--| Notes
--| Map must not be changed between the invocations of
--| Make_Values_Iterator (Map) and Next.
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Make_Keys_Iter . SPEC
-- . .
-- .......................................................
function Make_Bindings_Iter (Map: MAPPING) return BINDINGS_ITER;
--| Purpose
--| Create and return a bindings iterator based on map.
--| This object can then be used in conjunction with the
--| more function and the next procedure to iterate over
--| all key/value pairs in map. Raises Uninitialized_Mapping
--| iff map has not been initialized.
--|
--| Exceptions
--| Uninitialized_Mapping
--|
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.More . SPEC
-- . .
-- .......................................................
function More (Iter: BINDINGS_ITER) return BOOLEAN;
--| Purpose
--| Return true iff the bindings iterator has not been exhausted.
--|
--| Exceptions (none)
--| Notes (none)
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Next . SPEC
-- . .
-- .......................................................
procedure Next (Iter: in out BINDINGS_ITER;
Key: out KEY_TYPE;
Val: out VALUE_TYPE);
--| Purpose
--| Let iter be based on the MAPPING, map. Successive calls
--| of next will return the key/value pairs of map in some
--| arbitrary order. After all such pairs have been returned,
--| then the procedure will raise no_more.
--|
--| Exceptions
--| No_More
--|
--| Notes
--| Map must not be changed between the invocations of
--| Make_Bindings_Iterator (Map) and Next.
-- Heap management:
-- .......................................................
-- . .
-- . Hashed_Mapping_PKG.Destroy . SPEC
-- . .
-- .......................................................
procedure Destroy (M: in out MAPPING);
--| Purpose
--| Return space consumed by MAPPING value associated with
--| object m to the heap. (If m is uninitialized, this
--| operation does nothing.) If other objects share the
--| same MAPPING value, the further use of these objects is
--| erroneous. COMPONENTs of type VALUE_TYPE, if they are
--| access types, are not garbage collected. It is the user's
--| responsibility to dispose of these objects. m is left in
--| the uninitialized state.
--|
--| Exceptions (none)
--| Notes (none)
private
type COMPONENT is record
Key: KEY_TYPE;
Val: VALUE_TYPE;
end record;
function Equal (C1, C2: COMPONENT) return BOOLEAN;
-- Return true iff equal(c1.key, c2.key).
package Bucket_PKG is new Lists (COMPONENT, Equal);
use Bucket_PKG;
type BUCKET_ARRAY is array (BUCKET_RANGE) of LIST;
type MAPPING_REC is record
Size : NATURAL;
Buckets : BUCKET_ARRAY;
end record;
type MAPPING is access MAPPING_REC;
-- Representation Invariants:
-- 1. r /= null. (This would be the uninitialized case)
-- 2. If for some i, a COMPONENT, c, is in bucket r.buckets(i),
-- then hash(c.key) = i.
-- 3. If a COMPONENT, c1, is in bucket, r.buckets(i), then there is
-- no other c2 in r.buckets(i) such that equal(c1, c2).
-- (Enforce one binding to a given key at any time.)
-- 4. r.size equals the total number of COMPONENTs in buckets
-- r.buckets(BUCKET_RANGE'first) through
-- r.buckets(BUCKET_RANGE'last).
--
-- Abstraction Function:
-- A(r) is the set consisting of all key, value pairs that appear as
-- COMPONENTs in buckets r.buckets(BUCKET_RANGE'first) through
-- r.buckets(BUCKET_RANGE'last).
type GENERAL_ITER is record
Map : MAPPING;
Current : BUCKET_RANGE;
Position : LIST;
end record;
-- For a given general_iter, i, the make, more and next operations
-- have the following effects:
-- make: Sets map field to the given MAPPING, sets i.current to the
-- lowest idx of a nonempty bucket, and sets i.position to the head
-- of that bucket.
-- more: Returns not empty(i.position).
-- next: key, val fields of first COMPONENT of i.position.
-- Advances i.position to next COMPONENT in bucket, if it exists.
-- Otherwise, increments i.current until a nonempty bucket, and sets
-- i.position to this bucket. When this fails, sets i.position to an
-- empty bucket.
type KEYS_ITER is new general_iter;
type VALUES_ITER is new general_iter;
type BINDINGS_ITER is new general_iter;
end Hashed_Mapping_PKG;
--::::::::::
--ltrees.spc
--::::::::::
-- *************************************************
-- * *
-- * LABELED_TREES * SPEC
-- * *
-- *************************************************
with Lists;
generic
type LABEL_TYPE is private;
-- This is used to identify nodes in the tree.
type VALUE_TYPE is private;
-- Information being contained in a node of tree
with function "<" (X: in LABEL_TYPE; Y: in LABEL_TYPE)
return BOOLEAN is <> ;
-- Function which defines ordering of nodes
-- a < b -> not (b < a) and (b /= a) for all a and b.
package Labeled_Trees is
--| Purpose
--| This package creates an ordered binary tree. This will allow for
--| quick insertion, and search.
--|
--| The tree is organized such that
--|
--| label (leftchild) < label (root) label (root) < label (rightchild)
--|
--| This means that by doing a left to right search of the tree will
--| produce the nodes of the tree in ascending order.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Bill Toscano and Michael Gordon, Intermetrics, Inc.
type TREE is private;
type TREE_ITER is private;
Label_Already_Exists_In_Tree : exception;
Label_Not_Present : exception;
No_More : exception;
Tree_Is_Empty : exception;
-- ....................................................
-- . .
-- . LABELED_TREES.CREATE . SPEC
-- . .
-- ....................................................
function Create return TREE;
--| Purpose
--| This creates a tree containing no information and no children. An
--| emptytree.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.DESTROY_DEEP_TREE . SPEC
-- . .
-- ....................................................
generic
with procedure Dispose_Label (L :in out LABEL_TYPE);
with procedure Dispose_Value (V :in out VALUE_TYPE);
procedure Destroy_Deep_Tree (T : in out TREE);
--| Purpose
--| Destroys all nodes in a tree and the label and value associated
--| with each node.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.DESTROY_TREE . SPEC
-- . .
-- ....................................................
procedure Destroy_Tree (T : in out TREE);
--| Purpose
--| Destroys a tree and returns the space which it is occupying.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.FETCH_VALUE . SPEC
-- . .
-- ....................................................
function Fetch_Value (T : in TREE;
L : in LABEL_TYPE) return VALUE_TYPE;
--| Purpose
--| Get the value of the node with the given label.
--| If the label is not present Label_Not_Present is raised.
--|
--| Exceptions
--| Label_Not_Present
--|
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.FETCH_VALUE . SPEC
-- . .
-- ....................................................
function Fetch_Value (T : in TREE) return VALUE_TYPE;
--| Purpose
--| Return the value stored at the root node of the given tree.
--| Raises Label_Not_Present if the tree T is empty.
--|
--| Exceptions
--| Label_Not_Present
--|
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.GET_TREE . SPEC
-- . .
-- ....................................................
function Get_Tree (T : in TREE;
L : in LABEL_TYPE) return TREE;
--| Purpose
--| Get the subtree whose root is labelled L.
--|
--| Exceptions
--| Label_Not_Present if the label L is not in T
--|
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.FORWARD . SPEC
-- . .
-- ....................................................
procedure Forward (I : in out TREE_ITER);
--| Purpose
--| This is used to advance the iterator. Typically this is used in
--| conjunction with Node_Value and Node_Label.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.INSERT_NODE . SPEC
-- . .
-- ....................................................
procedure Insert_Node (T : in out TREE;
L : in LABEL_TYPE;
V : in VALUE_TYPE);
--| Purpose
--| Inserts a node into the specified tree.
--| This adds the node with label L to the tree T. Label_Already_Exists is
--| raised if L already exists in T.
--|
--| Exceptions
--| Label_Already_Exists
--|
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.IS_EMPTY . SPEC
-- . .
-- ....................................................
function Is_Empty (T : in TREE) return BOOLEAN;
--| Purpose
--| Returns TRUE iff the tree is empty.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.IS_LABEL_IN_TREE . SPEC
-- . .
-- ....................................................
function Is_Label_In_Tree (T : in TREE;
L : in LABEL_TYPE) return BOOLEAN;
--| Purpose
--| Returns TRUE iff the given labels is in the given tree.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.IS_LABEL_IN_TREE . SPEC
-- . .
-- ....................................................
procedure Is_Label_In_Tree (T : in TREE;
L : in LABEL_TYPE;
Subtree : out TREE;
Present : out BOOLEAN);
--| Purpose
--| This operation can be used to see if a label is in the tree.
--| It sets the variable Present to TRUE iff the given label is in
--| the given tree.
--| If it is, the Subtree out parameter can then be used to
--| to update the value field of the label. The sequence would be
--|
--| Is_Label_In_Tree (T, L, Subtree, Present);
--| if Present then
--| Store_Value (Subtree, SomeValue);
--| end if;
--|
--| If the label is not Present, then Subtree is the root of the tree
--| where the label would be stored if it were present. Thus the following
--| sequence would be useful.
--|
--| Is_Label_In_Tree (T, L, Subtree, Present);
--| if not Present then
--| Insert_Node (Subtree, L, V);
--| end if;
--|
--| The advantage to this routine is that the tree need only be searched
--| once instead of twice once for the existence check and then once for
--| the insertion.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.ITERATOR_LABEL . SPEC
-- . .
-- ....................................................
function Iterator_Label (I : in TREE_ITER) return LABEL_TYPE;
--| Purpose
--| Returns the label of the node corresponding to the iterator.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.ITERATOR_VALUE . SPEC
-- . .
-- ....................................................
function Iterator_Value (I : in TREE_ITER) return VALUE_TYPE;
--| Purpose
--| Returns the value of the node corresponding to the iterator.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.MAKE_TREE . SPEC
-- . .
-- ....................................................
function Make_Tree (L : in LABEL_TYPE;
V : in VALUE_TYPE) return TREE;
--| Purpose
--| Creates a tree whose root has the given label and value.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.MAKE_TREE_ITER_IN . SPEC
-- . .
-- ....................................................
function Make_Tree_Iter_In (T : in TREE) return TREE_ITER;
--| Purpose
--| This sets up an iteration of the nodes of the tree in inorder.
--| By using the Next operations the nodes of the tree are returned in
--| in inorder. Inorder means return the left child then the node
--| then the right child.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.MAKE_TREE_ITER_POST . SPEC
-- . .
-- ....................................................
function Make_Tree_Iter_Post (T : in TREE) return TREE_ITER;
--| Purpose
--| This sets up an iteration of the nodes of the tree in postorder.
--| By using the Next operations the nodes of the tree are returned in
--| post order. Post order means return the node first then its left child
--| and then its right child.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.MAKE_TREE_ITER_PRE . SPEC
-- . .
-- ....................................................
function Make_Tree_Iter_Pre (T : in TREE) return TREE_ITER;
--| Purpose
--| This sets up an iteration of the nodes of the tree in preorder.
--| By using the Next operations the nodes of the tree are returned in
--| ascending order.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.MORE . SPEC
-- . .
-- ....................................................
function More (I : in TREE_ITER) return BOOLEAN;
--| Purpose
--| Returns TRUE iff there are more elements in the tree to
--| iterate over.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.NEXT . SPEC
-- . .
-- ....................................................
procedure Next (I : in out TREE_ITER;
V : out VALUE_TYPE);
--| Purpose
--| This returns the next element in the iteration and advances the iterator.
--| No_More is raised when after the last element has been returned and
--| an attempt is made to get another element.
--|
--| Exceptions
--| No_More
--|
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.NEXT . SPEC
-- . .
-- ....................................................
procedure Next (I : in out TREE_ITER;
V : out VALUE_TYPE;
L : out LABEL_TYPE);
--| Purpose
--| This iteration operation returns the label of a node as well as the
--| node's value. No_More is raised if Next is called after the last
--| element of the tree has been returned.
--|
--| Exceptions
--| No_More
--|
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.STORE_VALUE . SPEC
-- . .
-- ....................................................
procedure Store_Value (T : in out TREE;
L : in LABEL_TYPE;
V : in VALUE_TYPE);
--| Purpose
--| Sets a new value V in the tree T at the node identified
--| by the label L.
--| Label_Not_Present is raised if L is not in T.
--|
--| Exceptions
--| Label_Not_Present
--|
--| Notes (none)
-- ....................................................
-- . .
-- . LABELED_TREES.STORE_VALUE . SPEC
-- . .
-- ....................................................
procedure Store_Value (T : in out TREE;
V : in VALUE_TYPE);
--| Purpose
--| This stores the value V in the root node of the tree T.
--| Raises Label_Not_Present if T is empty.
--|
--| Exceptions
--| Label_Not_Present
--|
--| Notes (none)
private
type NODE;
type TREE is access NODE;
type NODE is
record
Label : LABEL_TYPE;
Value : VALUE_TYPE;
Left_Child : TREE;
Right_Child : TREE;
end record;
package NODE_ORDER is new Lists (TREE);
type TREE_ITER is
record
Node_List : Node_Order.LIST;
State : Node_Order.LISTITER;
end record;
end Labeled_Trees;
--::::::::::
--set.spc
--::::::::::
-- ************************************************
-- * *
-- * SET_PKG * SPEC
-- * *
-- ************************************************
with Lists;
pragma Elaborate (Lists);
generic
type ELEM_TYPE is private;
with function Equal (E1, E2: ELEM_TYPE) return BOOLEAN is "=";
package Set_Pkg is
--| Purpose
--| This package provides the set abstract data type. All standard set
--| operations are provided. Standard mathematical set notation is
--| employed to describe the effects of the operations.
--|
--| The component type, and an equality relation used for membership
--| tests, are generic formals of the package. The implementation isn't
--| particularly fast, since the only available information about the
--| component type is the equality relation. However, this shouldn't be a
--| concern unless the sets become large or speed becomes important.
--| See scalar_set_pkg, hashed_set_pkg and ordered_set_pkg for other
--| implementations.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Programmer: Ron Kownacki, Intermetrics
--| One of a family of set packages:
type SET is private;
-- Exceptions:
No_More: exception; -- Raised on incorrect use of an iterator.
-- Iterators:
type MEMBERS_ITER is private; -- Members of a set in arbitrary order
-- Constructors:
-- ...............................................
-- . .
-- . SET_PKG.CREATE . SPEC
-- . .
-- ...............................................
function Create return SET;
--| Purpose
--| Return {}. This operation is not strictly necessary, since an
--| uninitialized set object is viewed as the empty set.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . SET_PKG.INSERT . SPEC
-- . .
-- ...............................................
procedure Insert (S: in out SET;
E: in ELEM_TYPE);
--| Purpose
--| Insert the element, e, into the set, s.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . SET_PKG.DELETE . SPEC
-- . .
-- ...............................................
procedure Delete (S: in out SET;
E: in ELEM_TYPE);
--| Purpose
--| If e is in s, then remove e from s. Otherwise, no effect.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . SET_PKG.INTERSECT . SPEC
-- . .
-- ...............................................
function Intersect (S1, S2: SET) return SET;
--| Purpose
--| Return {e | member(s1, e) and member(s2, e)}.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . SET_PKG.UNION . SPEC
-- . .
-- ...............................................
function Union (S1, S2: SET) return SET;
--| Purpose
--| Return {e | member(s1, e) or member(s2, e)}.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . SET_PKG.COPY . SPEC
-- . .
-- ...............................................
function Copy (S: SET) return SET;
--| Purpose
--| Returns a copy of s. Subsequent changes to s will not be
--| visible through the application of operations to the copy of s.
--| Assignment or parameter passing without copying will result
--| in a single set value being shared among objects.
--| The assignment operation is used to transfer the values of
--| the elem_type components of s; consequently, changes in these
--| values may be observable through both sets if these types are
--| access types, or if they contain access type components.
--|
--| Exceptions (none)
--| Notes (none)
-- Query Operations
-- ...............................................
-- . .
-- . SET_PKG.EQUAL . SPEC
-- . .
-- ...............................................
function Equal (S1, S2: SET) return BOOLEAN;
--| Purpose
--| Return (for all e: elem_type (member(s1, e) iff member(s2, e))).
--| Note that (s1 = s2) implies equal(s1, s2) holds for all time.
--| "=" is object equality, equal is state equality.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . SET_PKG.IS_EMPTY . SPEC
-- . .
-- ...............................................
function Is_Empty (S: SET) return BOOLEAN;
--| Purpose
--| Return s = {}.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . SET_PKG.IS_MEMBER . SPEC
-- . .
-- ...............................................
function Is_Member (S: SET; E: ELEM_TYPE) return BOOLEAN;
--| Purpose
--| Return true iff e is a member of s.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . SET_PKG.SIZE . SPEC
-- . .
-- ...............................................
function Size (S: SET) return NATURAL;
--| Purpose
--| Return |s|, the cardinality of s.
--|
--| Exceptions (none)
--| Notes (none)
-- Iterators
-- ...............................................
-- . .
-- . SET_PKG.MAKE_MEMBERS_ITER . SPEC
-- . .
-- ...............................................
function Make_Members_Iter (S: SET) return MEMBERS_ITER;
--| Purpose
--| Create and return a members iterator based on s. This object
--| can then be used in conjunction with the more function and the
--| next procedure to iterate over the members of s in some
--| arbitrary order.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . SET_PKG.MORE . SPEC
-- . .
-- ...............................................
function More (Iter: MEMBERS_ITER) return BOOLEAN;
--| Purpose
--| Return true iff the members iterator has not been exhausted.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . SET_PKG.NEXT . SPEC
-- . .
-- ...............................................
procedure Next (Iter: in out MEMBERS_ITER;
E: out ELEM_TYPE);
--| Purpose
--| Let iter be based on the set, s. Successive calls of next
--| will return the members of s in some arbitrary order.
--| After all members have been returned, then the procedure will
--| raise no_more.
--| Requires:
--| s must not be changed between the invocations of
--| make_nodes_iterator(g) and next.
--|
--| Exceptions
--| no_more
--|
--| Notes (none)
-- Heap management
-- ...............................................
-- . .
-- . SET_PKG.DESTROY . SPEC
-- . .
-- ...............................................
procedure Destroy (S: in out SET);
--| Purpose
--| Return space consumed by the set value associated with object
--| s to the heap. If other objects share the same set value, then
--| further use of these objects is erroneous. Components of type
--| elem_type, if they are access types, are not garbage collected.
--| It is the user's responsibility to dispose of these objects.
--| s is set to {}.
--|
--| Exceptions (none)
--| Notes (none)
private
package List_Pkg is new Lists (ELEM_TYPE, Equal);
use List_Pkg;
type SET is new LIST;
-- Representation Invariants:
-- None; all lists are legal representations of sets.
-- Abstraction Function: A: representation --> set
-- A(null) = create.
-- A(attach(r, e)) = insert(A(r), e).
-- Sufficient since all lists can be generated by null, attach.
--
-- Note that this implementation allows faster insertion and
-- membership testing than if duplicate insertions of an element
-- caused a check to ensure that each element is only kept once in
-- the list. This implies that deleting an element always involves
-- a scan of the entire list.
type MEMBERS_ITER is new LIST;
-- For a set, s, make returns members_iter(copy(list(s))).
-- More(iter) returns true iff list(iter) isn't empty.
-- Next(iter) returns the first element in list(iter). Before doing
-- this, it removes all occurrences of this element from list(iter).
end Set_Pkg;
--::::::::::
--stack.spc
--::::::::::
-- **************************************************
-- * *
-- * STACK_PKG * SPEC
-- * *
-- **************************************************
with Lists;
generic
type ELEM_TYPE is private;
package Stack_Pkg is
--| Purpose
--| This package provides the stack abstract data type. Element type is
--| a generic formal parameter to the package. There are no explicit
--| bounds on the number of objects that can be pushed onto a given stack.
--| All standard stack operations are provided.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Programmer: Ron Kownacki, Intermetrics
type STACK is private;
-- Exceptions:
Uninitialized_Stack: exception;
-- Raised on attempt to manipulate an uninitialized stack object.
-- The initialization operations are create and copy.
Empty_Stack: exception;
-- Raised by some operations when empty.
-- Constructors:
-- ..............................................................
-- . .
-- . STACK_PKG.CREATE . SPEC
-- . .
-- ..............................................................
function Create return STACK;
--| Purpose
--| Return the empty stack.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................................
-- . .
-- . STACK_PKG.PUSH . SPEC
-- . .
-- ..............................................................
procedure Push (S: in out STACK; E: in ELEM_TYPE);
--| Purpose
--| Push e onto the top of s.
--| Raises uninitialized_stack iff s has not been initialized.
--|
--| Exceptions
--| uninitialized_stack
--|
--| Notes (none)
-- ..............................................................
-- . .
-- . STACK_PKG.POP . SPEC
-- . .
-- ..............................................................
procedure Pop (S: in out STACK);
--| Purpose
--| Pops the top element from s, and throws it away.
--| Raises empty_stack iff s is empty.
--| Raises uninitialized_stack iff s has not been initialized.
--|
--| Exceptions
--| empty_stack
--| uninitialized_stack
--|
--| Notes (none)
-- ..............................................................
-- . .
-- . STACK_PKG.POP . SPEC
-- . .
-- ..............................................................
procedure Pop (S: in out STACK; E: out ELEM_TYPE);
--| Purpose
--| Pops the top element from s, returns it as the e parameter.
--| Raises empty_stack iff s is empty.
--| Raises uninitialized_stack iff s has not been initialized.
--|
--| Exceptions
--| empty_stack
--| uninitialized_stack
--|
--| Notes (none)
-- ..............................................................
-- . .
-- . STACK_PKG.COPY . SPEC
-- . .
-- ..............................................................
function Copy (S: STACK) return STACK;
--| Purpose
--| Return a copy of s.
--| Stack assignment and passing stacks as subprogram parameters
--| result in the sharing of a single stack value by two stack
--| objects; changes to one will be visible through the others.
--| copy can be used to prevent this sharing.
--| Raises uninitialized_stack iff s has not been initialized.
--|
--| Exceptions
--| uninitialized_stack
--|
--| Notes (none)
-- Queries:
-- ..............................................................
-- . .
-- . STACK_PKG.TOP . SPEC
-- . .
-- ..............................................................
function Top (S: STACK) return ELEM_TYPE;
--| Purpose
--| Return the element on the top of s. Raises empty_stack iff s is
--| empty.
--| Raises uninitialized_stack iff s has not been initialized.
--|
--| Exceptions
--| empty_stack
--| uninitialized_stack
--|
--| Notes (none)
-- ..............................................................
-- . .
-- . STACK_PKG.SIZE . SPEC
-- . .
-- ..............................................................
function Size (S: STACK) return NATURAL;
--| Purpose
--| Return the current number of elements in s.
--| Raises uninitialized_stack iff s has not been initialized.
--|
--| Exceptions
--| uninitialized_stack
--|
--| Notes (none)
-- ..............................................................
-- . .
-- . STACK_PKG.IS_EMPTY . SPEC
-- . .
-- ..............................................................
function Is_Empty (S: STACK) return BOOLEAN;
--| Purpose
--| Return true iff s is empty.
--| Raises uninitialized_stack iff s has not been initialized.
--|
--| Exceptions
--| uninitialized_stack
--|
--| Notes (none)
-- Heap Management:
-- ..............................................................
-- . .
-- . STACK_PKG.DESTROY . SPEC
-- . .
-- ..............................................................
procedure Destroy (S: in out STACK);
--| Purpose
--| Return the space consumed by s to the heap. No effect if s is
--| uninitialized. In any case, leaves s in uninitialized state.
--|
--| Exceptions (none)
--| Notes (none)
private
package Elem_List_Pkg is new Lists (ELEM_TYPE);
subtype ELEM_LIST is Elem_List_Pkg.LIST;
type STACK_REC is
record
Size: NATURAL := 0;
Elts: ELEM_LIST := Elem_List_Pkg.Create;
end record;
type STACK is access STACK_REC;
-- Let an instance of the representation type, r, be denoted by the
-- pair, <size, elts>. Dot selection is used to refer to these
-- components.
--
-- Representation Invariants:
-- r /= null
-- elem_list_pkg.length(r.elts) = r.size.
--
-- Abstraction Function:
-- A(<size, elem_list_pkg.create>) = stack_pkg.create.
-- A(<size, elem_list_pkg.attach(e, l)>) = push(A(<size, l>), e).
end Stack_Pkg;
--::::::::::
--clp.spc
--::::::::::
-- **********************************************
-- * *
-- * COMMAND_LINE_PROCESSOR (CLP) * SPEC
-- * *
-- **********************************************
package Command_Line_Processor is
--| Purpose
--| COMMAND_LINE_PROCESSOR is an abstract state machine
--| that allows the user to access a command line, which
--| may contain file references which are include files,
--| as a simple list of file names which can be accessed
--| via an interator and a Get function. The command line
--| syntax is:
--|
--| command input_file input_file ... output_file
--| or:
--| command input_file input_file ... input_file
--|
--| where any "input_file" may be prefixed by an "@"
--| to make it an include file.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--| Modifications
--| 2/19/90 Rick Conn Initial Design and Code
type COMMAND_LINE_LAYOUT is (ALL_INPUT_FILES,
ONE_OUTPUT_FILE);
-- the command line either contains only input
-- files or a group of input files and one
-- output file
-- ..............................................
-- . .
-- . CLP.INITIALIZE . SPEC
-- . .
-- ..............................................
procedure Initialize (Program_Name : in STRING;
Command_Kind : in COMMAND_LINE_LAYOUT
:= ONE_OUTPUT_FILE);
--| Purpose
--| Initialize the package, specifying a program
--| name which may be used by the Command Line
--| Interface
--|
--| Exceptions
--| ALLOCATION_PROBLEM
--| INIT_ERROR
--|
--| Notes
--| CALL INITIALIZE ONLY ONCE
-- ..............................................
-- . .
-- . CLP.RESET . SPEC
-- . .
-- ..............................................
procedure Reset;
--| Purpose
--| Reset the iterator.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . CLP.IS_END . SPEC
-- . .
-- ..............................................
function Is_End return BOOLEAN;
--| Purpose
--| Return TRUE if no more file names are
--| available.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . CLP.FILE_NAME . SPEC
-- . .
-- ..............................................
function File_Name return STRING;
--| Purpose
--| Return the name of the next file.
--|
--| Exceptions
--| END_OF_FILE_LIST
--|
--| Notes (none)
-- ..............................................
-- . .
-- . CLP.OUTPUT_FILE_NAME . SPEC
-- . .
-- ..............................................
function Output_File_Name return STRING;
--| Purpose
--| Return the name of the output file.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . CLP.FILE_NAME_COUNT . SPEC
-- . .
-- ..............................................
function File_Name_Count return NATURAL;
--| Purpose
--| Number of file names in command line.
ALLOCATION_PROBLEM : exception;
END_OF_FILE_LIST : exception;
INIT_ERROR : exception;
UNEXPECTED_ERROR : exception; -- raised anytime
end Command_Line_Processor;
--::::::::::
--lbintree.spc
--::::::::::
-- ********************************************************
-- * *
-- * LABELED_BINARY_TREES_PKG * SPEC
-- * *
-- ********************************************************
with Binary_Trees_Pkg;
generic
type LABEL_TYPE is private; -- Type for labels stored in the tree.
type VALUE_TYPE is private; -- Type for values stored in the tree.
with function Difference (P, Q: LABEL_TYPE) return INTEGER is <>;
-- Must return a value > 0 if P > Q, 0 if P = Q, and less than
-- zero otherwise, where P and Q are labels.
package Labeled_Binary_Trees_Pkg is
--| Purpose
--| This package provides labeled binary trees, which are the same as
--| unlabeled binary trees except that when searching for or inserting
--| a value into the tree, only the label field is compared.
--|
--| Initialization Exceptions (none)
--|
--| Notes
--| USAGE: (See Overview of Binary_Trees_Package)
--|
--| PERFORMANCE: (See Overview of Binary_Trees_Package)
--|
--| Modifications
--| Author: Bill Toscano and Michael Gordon, Intermetrics, Inc.
-- This should be private (but cannot be)
type LABEL_VALUE_PAIR is
record
Label : LABEL_TYPE;
Value : VALUE_TYPE;
end record;
function LV_Differ (P, Q: LABEL_VALUE_PAIR) return INTEGER;
package LVT is new Binary_Trees_Pkg (LABEL_VALUE_PAIR, LV_Differ);
-- Exceptions --
Duplicate_Value: exception renames LVT.Duplicate_Value;
-- Raised on attempt to insert a duplicate label into a tree.
Not_Found: exception renames LVT.Not_Found;
-- Raised on attempt to find a label that is not in a tree.
No_More: exception renames LVT.No_More;
-- Raised on attempt to bump an iterator that has already scanned the
-- entire tree.
Out_Of_Order: exception renames LVT.Out_Of_Order;
-- Raised if a problem in the ordering of a tree is detected.
Invalid_Tree: exception renames LVT.Invalid_Tree;
-- Value is not a tree or was not properly initialized.
-- Types --
subtype SCAN_KIND is LVT.SCAN_KIND;
--? function InOrder return LVT.Scan_Kind renames LVT.InOrder;
InOrder : constant SCAN_KIND := LVT.InOrder;
PreOrder : constant SCAN_KIND := LVT.PreOrder;
PostOrder : constant SCAN_KIND := LVT.PostOrder;
-- is (inorder, preorder, postorder);
-- Used to specify the order in which values should be scanned from a tree:
--
-- inorder: Left, Node, Right (nodes visited in increasing order)
-- preorder: Node, Left, Right (top down)
-- postorder: Left, Right, Node (bottom up)
subtype TREE is LVT.TREE;
subtype ITERATOR is LVT.ITERATOR;
-- Operations --
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.CREATE . SPEC
-- . .
-- ........................................................
Function Create return TREE renames LVT.Create;
--| Purpose
--| Create and return an empty tree. Note that this allocates
--| a small amount of storage which can only be reclaimed through
--| a call to Destroy.
--|
--| Exceptions (none)
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.INSERT . SPEC
-- . .
-- ........................................................
Procedure Insert (L: LABEL_TYPE;
V: VALUE_TYPE;
T: TREE);
--| Purpose
--| Insert (L, V) into T in the proper place. If a label equal
--| to L (according to the Difference function) is already contained
--| in the tree, the exception Duplicate_Label is raised.
--| Caution: Since this package does not attempt to balance trees as
--| values are inserted, it is important to remember that inserting
--| labels in sorted order will create a degenerate tree, where search
--| and insertion is proportional to the N instead of to Log N. If
--| this pattern is common, use the Balanced_Tree function below.
--|
--| Exceptions
--| Duplicate_Value
--| Invalid_Tree
--|
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.INSERT_IF_NOT_FOUND . SPEC
-- . .
-- ........................................................
procedure Insert_if_not_Found (L : LABEL_TYPE;
V : VALUE_TYPE;
T : TREE;
Found : out BOOLEAN;
Duplicate : out VALUE_TYPE);
--| Purpose
--| Insert V into T in the proper place. If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, Found will be True and Duplicate will be the duplicate
--| value. This might be a sequence of values with the same key, and
--| V can then be added to the sequence.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.REPLACE_IF_FOUND . SPEC
-- . .
-- ........................................................
procedure Replace_if_Found (L : LABEL_TYPE;
V : VALUE_TYPE;
T : TREE;
Found : out BOOLEAN;
Old_Value : out VALUE_TYPE);
--| Purpose
--| Search for L in T. If found, replace the old value with V,
--| and return Found => True, Old_Value => the old value. Otherwise,
--| simply insert the L, V pair into T and return Found => False.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.DESTROY . SPEC
-- . .
-- ........................................................
procedure Destroy (T: in out TREE) renames LVT.Destroy;
--| Purpose
--| The space allocated to T is reclaimed. The space occupied by
--| the values stored in T is not however, recovered.
--|
--| Exceptions (none)
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.DESTROY_DEEP . SPEC
-- . .
-- ........................................................
generic
with procedure Free_Value (V: in out VALUE_TYPE) is <>;
with procedure Free_Label (L: in out LABEL_TYPE) is <>;
procedure Destroy_Deep (T: in out TREE);
--| Purpose
--| The space allocated to T is reclaimed. The values and
--| labels stored it T are reclaimed using Free_Label and
--| Free_Value, and the tree nodes themselves
--| are then reclaimed (in a single walk of the tree).
--|
--| Exceptions (none)
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.BALANCED_TREE . SPEC
-- . .
-- ........................................................
generic
with procedure Next_Pair (L: in out LABEL_TYPE; V: in out VALUE_TYPE)
is <>;
-- Each call to this procedure should return the next (Label, Value)
-- pair to be
-- inserted into the balanced tree being created. If necessary,
-- this function should check that each value is greater than the
-- previous one, and raise Out_of_Order if necessary. If values
-- are not returned in strictly increasing order, the results are
-- unpredictable.
function Balanced_Tree (Count: NATURAL) return TREE;
--| Purpose
--| Create a balanced tree by calling next_Pair Count times.
--| Each time Next_Pair is called, it must return a label that compares
--| greater than the preceeding label. This function is useful for balancing
--| an existing tree (next_Pair iterates over the unbalanced tree) or
--| for creating a balanced tree when reading data from a file which is
--| already sorted.
--|
--| Exceptions (none)
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.COPY_TREE . SPEC
-- . .
-- ........................................................
generic
with function Copy_Label (L: LABEL_TYPE) return LABEL_TYPE is <>;
with function Copy_Value (V: VALUE_TYPE) return VALUE_TYPE is <>;
-- This function is called to copy a value from the old tree to the
-- new tree.
Function Copy_Tree (T: TREE) return TREE;
--| Purpose
--| Create a balanced tree that is a copy of the tree T.
--| The exception Invalid_Tree is raised if T is not a valid tree.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.IS_EMPTY . SPEC
-- . .
-- ........................................................
function Is_Empty (T: TREE) return BOOLEAN renames LVT.Is_Empty;
--| Purpose
--| Return TRUE iff T is an empty tree or if T was not initialized.
--|
--| Exceptions (none)
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.FIND . SPEC
-- . .
-- ........................................................
Function Find (L: LABEL_TYPE;
T: TREE) return VALUE_TYPE;
--| Purpose
--| Search T for a label that matches L. The corresponding value
--| is returned. If no matching label is found, the exception Not_Found
--| is raised.
--|
--| Exceptions
--| Not_Found
--| Invalid_Tree
--|
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.FIND . SPEC
-- . .
-- ........................................................
Procedure Find (L : LABEL_TYPE;
T : TREE;
Found : out BOOLEAN;
Match : out VALUE_TYPE);
--| Purpose
--| Search T for a label that matches L. On return, if Found is
--| TRUE then the corresponding value is returned in Match. Otherwise,
--| Found is FALSE and Match is undefined.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.IS_FOUND . SPEC
-- . .
-- ........................................................
function Is_Found (L: LABEL_TYPE;
T: TREE) return BOOLEAN;
--| Purpose
--| Return TRUE iff L is found in T.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.SIZE . SPEC
-- . .
-- ........................................................
function Size (T: TREE) return NATURAL renames LVT.Size;
--| Purpose
--| Return the number of values stored in T.
--|
--| Exceptions (none)
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.VISIT . SPEC
-- . .
-- ........................................................
generic
with procedure Process(L: LABEL_TYPE; V: VALUE_TYPE) is <>;
procedure Visit (T : TREE;
Order : SCAN_KIND);
--| Purpose
--| Invoke Process(V) for each value V in T. The nodes are visited
--| in the order specified by Order. Although more limited than using
--| an iterator, this function is also much faster.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.MAKE_ITER . SPEC
-- . .
-- ........................................................
function Make_Iter (T: TREE) return ITERATOR renames LVT.Make_Iter;
--| Purpose
--| Create an iterator over a tree.
--|
--| Exceptions
--| Invalid_Tree
--|
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.MORE . SPEC
-- . .
-- ........................................................
function More (I: ITERATOR) return BOOLEAN renames LVT.More;
--| Purpose
--| Return TRUE iff unscanned nodes remain in the tree being
--| scanned by I.
--|
--| Exceptions (none)
--| Notes (none)
-- ........................................................
-- . .
-- . LABELED_BINARY_TREES_PKG.NEXT . SPEC
-- . .
-- ........................................................
procedure Next (I: in out ITERATOR;
L: out LABEL_TYPE;
V: out VALUE_TYPE);
--| Purpose
--| Return the next value in the tree being scanned by I.
--| The exception No_More is raised if there are no more values to scan.
--|
--| Exceptions
--| No_More
--|
--| Notes (none)
end Labeled_Binary_Trees_Pkg;
--::::::::::
--ordset.spc
--::::::::::
-- ****************************************************
-- * *
-- * ORDEREDSETS * SPEC
-- * *
-- ****************************************************
with BinaryTrees;
generic
type ITEMTYPE is private;
with function "<" (X, Y : in ITEMTYPE) return BOOLEAN;
package OrderedSets is
--| Purpose
--| This abstractions is a counted ordered set. This means that
--| associated with each member of the set is a count of the number of
--| times it appears in the set. The order part means that there is
--| an ordering associated with the members. This allows fast insertion.
--| It also makes it easy to iterate over the set in order.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Bill Toscano and Michael Gordon, Intermetrics
type SET is private;
type SETITER is private;
-- .....................................................
-- . .
-- . ORDEREDSETS.CARDINALITY . SPEC
-- . .
-- .....................................................
function Cardinality (S : in SET) return NATURAL;
--| Purpose
--| Return the number of members in the set.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . ORDEREDSETS.CREATE . SPEC
-- . .
-- .....................................................
function Create return SET;
--| Purpose
--| Return the empty set.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . ORDEREDSETS.DESTROY . SPEC
-- . .
-- .....................................................
procedure Destroy (S : in out SET);
--| Purpose
--| Destroy a set and return its space.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . ORDEREDSETS.GETCOUNT . SPEC
-- . .
-- .....................................................
function GetCount (I : in SETITER) return NATURAL;
--| Purpose
--| Returns the count associated with the member corresponding to the
--| current interator I.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . ORDEREDSETS.INSERT . SPEC
-- . .
-- .....................................................
procedure Insert (M : in ITEMTYPE;
S : in out SET);
--| Purpose
--| Insert a member M into set S.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . ORDEREDSETS.MAKESETITER . SPEC
-- . .
-- .....................................................
function MakeSetIter (S : in SET) return SETITER;
--| Purpose
--| Prepares a user for an iteration operation by returning
--| a SetIter.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . ORDEREDSETS.MORE . SPEC
-- . .
-- .....................................................
function More (I : in SETITER) return BOOLEAN;
--| Purpose
--| Returns TRUE if there are more elements in the set
--| to iterate over.
--|
--| Exceptions (none)
--| Notes (none)
-- .....................................................
-- . .
-- . ORDEREDSETS.NEXT . SPEC
-- . .
-- .....................................................
procedure Next (I : in out SETITER;
M : out ITEMTYPE);
--| Purpose
--| Returns the current member in the iteration and increments
--| the iterator.
--|
--| Exceptions (none)
--| Notes (none)
private
type MEMBER is
record
Info : ITEMTYPE;
Count : NATURAL;
end record;
function "<" (X: in MEMBER; Y: in MEMBER) return BOOLEAN;
package TreePkg is new BinaryTrees (ITEMTYPE => MEMBER, "<" => "<");
type SET is
record
SetRep :TreePkg.TREE;
end record;
type SETITER is
record
Place : TreePkg.TREEITER;
Count : NATURAL;
end record;
end OrderedSets;
--::::::::::
--string.spc
--::::::::::
-- **********************************************
-- * *
-- * STRING_PKG * SPEC
-- * *
-- **********************************************
package String_Pkg is
--| Purpose
--| Package string_pkg exports an abstract data type, string_type. A
--| string_type value is a sequence of characters. The values have arbitrary
--| length. For a value, s, with length, l, the individual characters are
--| numbered from 1 to l. These values are immutable; characters cannot be
--| replaced or appended in a destructive fashion.
--|
--| In the documentation for this package, we are careful to distinguish
--| between string_type objects, which are Ada objects in the usual sense,
--| and string_type values, the members of this data abstraction as described
--| above. A string_type value is said to be associated with, or bound to,
--| a string_type object after an assignment (:=) operation.
--|
--| The operations provided in this package fall into three categories:
--|
--| 1. Constructors: These functions typically take one or more string_type
--| objects as arguments. They work with the values associated with
--| these objects, and return new string_type values according to
--| specification. By a slight abuse of language, we will sometimes
--| coerce from string_type objects to values for ease in description.
--|
--| 2. Heap Management:
--| These operations (make_persistent, flush, mark, release) control the
--| management of heap space. Because string_type values are
--| allocated on the heap, and the type is not limited, it is necessary
--| for a user to assume some responsibility for garbage collection.
--| String_type is not limited because of the convenience of
--| the assignment operation, and the usefulness of being able to
--| instantiate generic units that contain private type formals.
--| ** Important: To use this package properly, it is necessary to read
--| the descriptions of the operations in this section.
--|
--| 3. Queries: These functions return information about the values
--| that are associated with the argument objects. The same conventions
--| for description of operations used in (1) is adopted.
--|
--| A note about design decisions... The decision to not make the type
--| limited causes two operations to be carried over from the representation.
--| These are the assignment operation, :=, and the "equality" operator, "=".
--| See the discussion at the beginning of the Heap Management section for a
--| discussion of :=.
--| See the spec for the first of the equal functions for a discussion of "=".
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Programmer: Ron Kownacki, Intermetrics
type STRING_TYPE is private;
type COMPARISON_OPTION is (CASE_SENSITIVE, CASE_INSENSITIVE);
-- Used for equal, "<" and "<=" functions. If the comparison_option
-- is case_sensitive, then a straightforward comparison of values
-- is performed. If the option is case_insensitive, then comparison
-- between the arguments is performed after first normalizing them to
-- lower case.
Bounds: exception; -- Raised on index out of bounds.
Any_Empty: exception; -- Raised on incorrect use of match_any.
Illegal_Alloc: exception; -- Raised by value creating operations.
Illegal_Dealloc: exception; -- Raised by release.
-- Constructors:
-- ...............................................
-- . .
-- . STRING_PKG.CREATE . SPEC
-- . .
-- ...............................................
function Create (S: in STRING) return STRING_TYPE;
--| Purpose
--| Return a value consisting of the sequence of characters in s.
--| Sometimes useful for array or record aggregates.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.& . SPEC
-- . .
-- ...............................................
function "&" (S1, S2: in STRING_TYPE) return STRING_TYPE;
--| Purpose
--| Return the concatenation of s1 and s2.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.& . SPEC
-- . .
-- ...............................................
function "&" (S1: in STRING_TYPE; S2: in STRING) return STRING_TYPE;
--| Purpose
--| Return the concatenation of s1 and create(s2).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.& . SPEC
-- . .
-- ...............................................
function "&" (S1: in STRING; S2: in STRING_TYPE) return STRING_TYPE;
--| Purpose
--| Return the concatenation of create(s1) and s2.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.SUBSTR . SPEC
-- . .
-- ...............................................
function Substr (S : in STRING_TYPE;
I : in POSITIVE;
Len : in NATURAL)
return STRING_TYPE;
--| Purpose
--| Return the substring, of specified length, that occurs in s at
--| position i. If len = 0, then returns the empty value.
--| Otherwise, raises bounds if either i or (i + len - 1)
--| is not in 1..length(s).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.SPLICE . SPEC
-- . .
-- ...............................................
function Splice (S : in STRING_TYPE;
I : in POSITIVE;
Len : in NATURAL)
return STRING_TYPE;
--| Purpose
--| Let s be the string, abc, where a, b and c are substrings. If
--| substr(s, i, length(b)) = b, for some i in 1..length(s), then
--| splice(s, i, length(b)) = ac.
--| Returns a value equal to s if len = 0. Otherwise, raises bounds if
--| either i or (i + len - 1) is not in 1..length(s).
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.INSERT . SPEC
-- . .
-- ...............................................
function Insert (S1, S2: in STRING_TYPE; I: in POSITIVE)
return STRING_TYPE;
--| Purpose
--| Return substr(s1, 1, i - 1) & s2 & substr(s1, i, length(s1)).
--| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
--| exception is raised by insert.
--| Raises bounds if i is not in 1..length(s1) + 1.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| bounds
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.INSERT . SPEC
-- . .
-- ...............................................
function Insert (S1 : in STRING_TYPE;
S2 : in STRING;
I : in POSITIVE)
return STRING_TYPE;
--| Purpose
--| Return substr(s1, 1, i - 1) & s2 & substr(s1, i, length(s1)).
--| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
--| exception is raised by insert.
--| Raises bounds if i is not in 1..length(s1) + 1.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| bounds
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.INSERT . SPEC
-- . .
-- ...............................................
function Insert (S1 : in STRING;
S2 : in STRING_TYPE;
I : in POSITIVE)
return STRING_TYPE;
--| Purpose
--| Return s1(s1'first..i - 1) & s2 & s1(i..s1'last).
--| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no
--| exception is raised by insert.
--| Raises bounds if i is not in s'first..s'last + 1.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| bounds
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.LOWER . SPEC
-- . .
-- ...............................................
function Lower (S: in STRING) return STRING_TYPE;
--| Purpose
--| Return a value that contains exactly those characters in s with
--| the exception that all upper case characters are replaced by their
--| lower case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.LOWER . SPEC
-- . .
-- ...............................................
function Lower (S: in STRING_TYPE) return STRING_TYPE;
--| Purpose
--| Return a value that is a copy of s with the exception that all
--| upper case characters are replaced by their lower case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.UPPER . SPEC
-- . .
-- ...............................................
function Upper (S: in STRING) return STRING_TYPE;
--| Purpose
--| Return a value that contains exactly those characters in s with
--| the exception that all lower case characters are replaced by their
--| upper case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| illegal_alloc
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.UPPER . SPEC
-- . .
-- ...............................................
function Upper (S: in STRING_TYPE) return STRING_TYPE;
--| Purpose
--| Return a value that is a copy of s with the exception that all
--| lower case characters are replaced by their upper case counterparts.
--| Raises illegal_alloc if string space has been improperly
--| released. (See procedures mark/release.)
--|
--| Exceptions
--| illegal_alloc
--|
--| Notes (none)
-- Heap Management (including object/value binding):
--
-- Two forms of heap management are provided. The general scheme is to "mark"
-- the current state of heap usage, and to "release" in order to reclaim all
-- space that has been used since the last mark. However, this alone is
-- insufficient because it is frequently desirable for objects to remain
-- associated with values for longer periods of time, and this may come into
-- conflict with the need to clean up after a period of "string hacking."
-- To deal with this problem, we introduce the notions of "persistent" and
-- "nonpersistent" values.
--
-- The nonpersistent values are those that are generated by the constructors
-- in the previous section. These are claimed by the release procedure.
-- Persistent values are generated by the two make_persistent functions
-- described below. These values must be disposed of individually by means of
-- the flush procedure.
--
-- This allows a description of the meaning of the ":=" operation. For a
-- statement of the form, s := expr, where expr is a STRING_TYPE expression,
-- the result is that the value denoted/created by expr becomes bound to the
-- the object, s. Assignment in no way affects the persistence of the value.
-- If expr happens to be an object, then the value associated with it will be
-- shared. Ideally, this sharing would not be visible, since values are
-- immutable. However, the sharing may be visible because of the memory
-- management, as described below. Programs which depend on such sharing are
-- erroneous.
-- ...............................................
-- . .
-- . STRING_PKG.MAKE_PERSISTENT . SPEC
-- . .
-- ...............................................
function Make_Persistent (S: in STRING_TYPE) return STRING_TYPE;
--| Purpose
--| Returns a persistent value, v, containing exactly those characters in
--| value(s). The value v will not be claimed by any subsequent release.
--| Only an invocation of flush will claim v. After such a claiming
--| invocation of flush, the use (other than :=) of any other object to
--| which v was bound is erroneous, and program_error may be raised for
--| such a use.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.MAKE_PERSISTENT . SPEC
-- . .
-- ...............................................
function Make_Persistent (S: in STRING) return STRING_TYPE;
--| Purpose
--| Returns a persistent value, v, containing exactly those chars in s.
--| The value v will not be claimed by any subsequent release.
--| Only an invocation of flush will reclaim v. After such a claiming
--| invocation of flush, the use (other than :=) of any other object to
--| which v was bound is erroneous, and program_error may be raised for
--| such a use.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.FLUSH . SPEC
-- . .
-- ...............................................
procedure Flush (S: in out STRING_TYPE);
--| Purpose
--| Return heap space used by the value associated with s, if any, to
--| the heap. s becomes associated with the empty value. After an
--| invocation of flush claims the value, v, then any use (other than :=)
--| of an object to which v was bound is erroneous, and program_error
--| may be raised for such a use.
--|
--| This operation should be used only for persistent values. The mark
--| and release operations are used to deallocate space consumed by other
--| values. For example, flushing a nonpersistent value implies that a
--| release that tries to claim this value will be erroneous, and
--| program_error may be raised for such a use.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.MARK . SPEC
-- . .
-- ...............................................
procedure Mark;
--| Purpose
--| Marks the current state of heap usage for use by release.
--| An implicit mark is performed at the beginning of program execution.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.RELEASE . SPEC
-- . .
-- ...............................................
procedure Release;
--| Purpose
--| Releases all heap space used by nonpersistent values that have been
--| allocated since the last mark. The values that are claimed include
--| those bound to objects as well as those produced and discarded during
--| the course of general "string hacking." If an invocation of release
--| claims a value, v, then any subsequent use (other than :=) of any
--| other object to which v is bound is erroneous, and program_error may
--| be raised for such a use.
--|
--| Raises illegal_dealloc if the invocation of release does not balance
--| an invocation of mark. It is permissible to match the implicit
--| initial invocation of mark. However, subsequent invocations of
--| constructors will raise the illegal_alloc exception until an
--| additional mark is performed. (Anyway, there is no good reason to
--| do this.) In any case, a number of releases matching the number of
--| currently active marks is implicitly performed at the end of program
--| execution.
--|
--| Good citizens generally perform their own marks and releases
--| explicitly. Extensive string hacking without cleaning up will
--| cause your program to run very slowly, since the heap manager will
--| be forced to look hard for chunks of space to allocate.
--|
--| Exceptions
--| illegal_dealloc
--|
--| Notes (none)
-- Queries:
-- ...............................................
-- . .
-- . STRING_PKG.IS_EMPTY . SPEC
-- . .
-- ...............................................
function Is_Empty (S: in STRING_TYPE) return BOOLEAN;
--| Purpose
--| Return TRUE iff s is the empty sequence of characters.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.LENGTH . SPEC
-- . .
-- ...............................................
function Length (S: in STRING_TYPE) return NATURAL;
--| Purpose
--| Return number of characters in s.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.VALUE . SPEC
-- . .
-- ...............................................
function Value (S: in STRING_TYPE) return STRING;
--| Purpose
--| Return a string, s2, that contains the same characters that s
--| contains. The properties, s2'first = 1 and s2'last = length(s),
--| are satisfied. This implies that, for a given string, s3,
--| value(create(s3))'first may not equal s3'first, even though
--| value(create(s3)) = s3 holds. Thus, "content equality" applies
--| although the string objects may be distinguished by the use of
--| the array attributes.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.FETCH . SPEC
-- . .
-- ...............................................
function Fetch (S: in STRING_TYPE;
I: in POSITIVE) return CHARACTER;
--| Purpose
--| Return the ith character in s. Characters are numbered from
--| 1 to length(s). Raises bounds if i not in 1..length(s).
--|
--| Exceptions
--| bounds
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.SET_COMPARISON_OPTION . SPEC
-- . .
-- ...............................................
procedure Set_Comparison_Option (Choice: in COMPARISON_OPTION);
--| Purpose
--| Set the comparison option for equal, "<" and "<=" (as described
--| above) to the given choice. The initial setting is case_sensitive.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.GET_COMPARISON_OPTION . SPEC
-- . .
-- ...............................................
function Get_Comparison_Option return COMPARISON_OPTION;
--| Purpose
--| Return the current comparison_option setting.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.EQUAL . SPEC
-- . .
-- ...............................................
function Equal (S1, S2: in STRING_TYPE) return BOOLEAN;
--| Purpose
--| Value equality relation; return true iff length(s1) = length(s2)
--| and, for all i in 1..length(s1), fetch(s1, i) = fetch(s2, i).
--| (If the comparison_option is currently case_insensitive, then
--| lower(s1) and lower(s2) are used instead.)
--|
--| Exceptions (none)
--|
--| Notes
--| The "=" operation is carried over from the representation.
--| It allows one to distinguish among the heap addresses of
--| STRING_TYPE values. Even "equal" values under case_sensitive
--| comparison may not be "=", although s1 = s2 implies equal(s1, s2).
--| There is no reason to use "=".
-- ...............................................
-- . .
-- . STRING_PKG.EQUAL . SPEC
-- . .
-- ...............................................
function Equal (S1: in STRING_TYPE; S2: in STRING) return BOOLEAN;
--| Purpose
--| Return equal(s1, create(s2)).
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.EQUAL . SPEC
-- . .
-- ...............................................
function Equal (S1: in STRING; S2: in STRING_TYPE) return BOOLEAN;
--| Purpose
--| Return equal(create(s1), s2).
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG."<" . SPEC
-- . .
-- ...............................................
function "<" (S1, S2: in STRING_TYPE) return BOOLEAN;
--| Purpose
--| Lexicographic comparison according to the current comparison_option;
--| return value(s1) < value(s2).
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG."<" . SPEC
-- . .
-- ...............................................
function "<" (S1: in STRING_TYPE; S2: in STRING) return BOOLEAN;
--| Purpose
--| Lexicographic comparison according to the current comparison_option;
--| return value(s1) < s2.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG."<" . SPEC
-- . .
-- ...............................................
function "<" (S1: in STRING; S2: in STRING_TYPE) return BOOLEAN;
--| Purpose
--| Lexicographic comparison according to the current comparison_option;
--| return s1 < value(s2).
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG."<=" . SPEC
-- . .
-- ...............................................
function "<=" (S1, S2: in STRING_TYPE) return BOOLEAN;
--| Purpose
--| Lexicographic comparison according to the current comparison_option;
--| return value(s1) <= value(s2).
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG."<=" . SPEC
-- . .
-- ...............................................
function "<=" (S1: in STRING_TYPE; S2: in STRING) return BOOLEAN;
--| Purpose
--| Lexicographic comparison according to the current comparison_option;
--| return value(s1) <= s2.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG."<=" . SPEC
-- . .
-- ...............................................
function "<=" (S1: in STRING; S2: in STRING_TYPE) return BOOLEAN;
--| Purpose
--| Lexicographic comparison according to the current comparison_option;
--| return s1 <= value(s2).
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.MATCH_C . SPEC
-- . .
-- ...............................................
function Match_C (S : in STRING_TYPE;
C : in CHARACTER;
Start : in POSITIVE := 1) return NATURAL;
--| Purpose
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) = c. Returns 0 if no such i exists,
--| including the case where is_empty(s).
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.MATCH_NOT_C . SPEC
-- . .
-- ...............................................
function Match_Not_C (S : in STRING_TYPE;
C : in CHARACTER;
Start : in POSITIVE := 1) return NATURAL;
--| Purpose
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) /= c. Returns 0 if no such i exists,
--| including the case where is_empty(s).
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.MATCH_S . SPEC
-- . .
-- ...............................................
function Match_S (S1, S2: in STRING_TYPE; Start: in POSITIVE := 1)
return natural;
--| Purpose
--| Return the minimum index, i, in start..length(s1), such that,
--| for all j in 1..length(s2), fetch(s2, j) = fetch(s1, i + j - 1).
--| This is the position of the substring, s2, in s1.
--| Returns 0 if no such i exists, including the cases
--| where is_empty(s1) or is_empty(s2).
--| Note that equal(substr(s1, match_s(s1, s2, i), length(s2)), s2)
--| holds, providing that match_s does not raise an exception.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.MATCH_S . SPEC
-- . .
-- ...............................................
function Match_S (S1 : in STRING_TYPE;
S2 : in STRING;
Start : in POSITIVE := 1) return NATURAL;
--| Purpose
--| Return the minimum index, i, in start..length(s1), such that,
--| for all j in s2'range, s2(j) = fetch(s1, i + j - 1).
--| This is the position of the substring, s2, in s1.
--| Returns 0 if no such i exists, including the cases
--| where is_empty(s1) or s2 = "".
--| Note that equal(substr(s1, match_s(s1, s2, i), s2'length), s2)
--| holds, providing that match_s does not raise an exception.
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.MATCH_ANY . SPEC
-- . .
-- ...............................................
function Match_Any (S, Any : in STRING_TYPE;
Start : in POSITIVE := 1) return NATURAL;
--| Purpose
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) = fetch(any, j), for some j in 1..length(any).
--| Raises any_empty if is_empty(any).
--| Otherwise, returns 0 if no such i exists, including the case
--| where is_empty(s).
--|
--| Exceptions
--| any_empty
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.MATCH_ANY . SPEC
-- . .
-- ...............................................
function Match_Any (S : in STRING_TYPE;
Any : in STRING;
Start : in POSITIVE := 1) return NATURAL;
--| Purpose
--| Return the minimum index, i, in start..length(s), such that
--| fetch(s, i) = any(j), for some j in any'range.
--| Raises any_empty if any = "".
--| Otherwise, returns 0 if no such i exists, including the case
--| where is_empty(s).
--|
--| Exceptions
--| any_empty
--|
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.MATCH_NONE . SPEC
-- . .
-- ...............................................
function Match_None (S, None : in STRING_TYPE;
Start : in POSITIVE := 1) return NATURAL;
--| Purpose
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) /= fetch(none, j) for each j in 1..length(none).
--| If (not is_empty(s)) and is_empty(none), then i is 1.
--| Returns 0 if no such i exists, including the case
--| where is_empty(s).
--|
--| Exceptions (none)
--| Notes (none)
-- ...............................................
-- . .
-- . STRING_PKG.MATCH_NONE . SPEC
-- . .
-- ...............................................
function Match_None (S : in STRING_TYPE;
None : in STRING;
Start : in POSITIVE := 1) return NATURAL;
--| Purpose
--| Return the minimum index, i in start..length(s), such that
--| fetch(s, i) /= none(j) for each j in none'range.
--| If not is_empty(s) and none = "", then i is 1.
--| Returns 0 if no such i exists, including the case
--| where is_empty(s).
--|
--| Exceptions (none)
--| Notes (none)
private
type STRING_TYPE is access STRING;
-- Abstract data type, STRING_TYPE, is a constant sequence of chars
-- of arbitrary length. Representation type is access string.
-- It is important to distinguish between an object of the rep type
-- and its value; for an object, r, val(r) denotes the value.
--
-- Representation Invariant: I: rep --> boolean
-- I(r: rep) = (val(r) = null) or else
-- (val(r).all'first = 1 &
-- val(r).all'last >= 0 &
-- (for all r2, val(r) = val(r2) /= null => r is r2))
--
-- Abstraction Function: A: rep --> STRING_TYPE
-- A(r: rep) = if r = null then
-- the empty sequence
-- elsif r'last = 0 then
-- the empty sequence
-- else
-- the sequence consisting of r(1),...,r(r'last).
end String_Pkg;
--::::::::::
--sscan.spc
--::::::::::
-- **********************************************
-- * *
-- * STRING_SCANNER * SPEC
-- * *
-- **********************************************
with String_Pkg;
use String_Pkg;
package String_Scanner is
--| Purpose
--| Functions for scanning tokens from strings.
--|
--| This package provides a set of functions used to scan tokens from
--| strings. After the function make_Scanner is called to convert a string
--| into a string Scanner, the rest of the functions may be called to scan
--| various tokens from the string.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--| Modifications
--| Source: Bill Toscano and Michael Gordon, Intermetrics
type SCANNER is private;
Out_Of_Bounds : exception;
-- Raised when a operation is attempted on a
-- Scanner that has passed the end
Scanner_Already_Marked : exception;
-- Raised when a Mark is attemped on a Scanner
-- that has already been marked
-- ..............................................
-- . .
-- . STRING_SCANNER.MAKE_SCANNER . SPEC
-- . .
-- ..............................................
function Make_Scanner (S : in STRING_TYPE) return SCANNER;
--| Purpose
--| Construct a Scanner from S.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.DESTROY_SCANNER . SPEC
-- . .
-- ..............................................
procedure Destroy_Scanner (T : in out SCANNER);
--| Purpose
--| Free space occupied by the Scanner.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.MORE . SPEC
-- . .
-- ..............................................
function More (T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff additional characters remain to be scanned.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.FORWARD . SPEC
-- . .
-- ..............................................
procedure Forward (T : in SCANNER);
--| Purpose
--| Advance the scanner position.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.BACKWARD . SPEC
-- . .
-- ..............................................
procedure Backward (T : in SCANNER);
--| Purpose
--| Bump back the scanner position.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.GET . SPEC
-- . .
-- ..............................................
function Get (T : in SCANNER) return CHARACTER;
--| Purpose
--| Return character at the current Scanner position.
--| The scanner position remains unchanged.
--|
--| Exceptions
--| Out_Of_Bounds
--|
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.NEXT . SPEC
-- . .
-- ..............................................
procedure Next (T : in SCANNER;
C : out CHARACTER);
--| Purpose
--| Return character at the current Scanner position and update
--| the position.
--|
--| Exceptions
--| Out_Of_Bounds
--|
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.POSITION . SPEC
-- . .
-- ..............................................
function Position (T : in SCANNER) return POSITIVE;
--| Purpose
--| Return a positive integer indicating the current Scanner position,
--|
--| Exceptions
--| Out_Of_Bounds
--|
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.GET_STRING . SPEC
-- . .
-- ..............................................
function Get_String (T : in SCANNER) return STRING_TYPE;
--| Purpose
--| Return a String_Type corresponding to the contents of the Scanner
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.GET_REMAINDER . SPEC
-- . .
-- ..............................................
function Get_Remainder (T : in SCANNER) return STRING_TYPE;
--| Purpose
--| Return a String_Type starting at the current index of the Scanner
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.MARK . SPEC
-- . .
-- ..............................................
procedure Mark (T : in SCANNER);
--| Purpose
--| Mark the current index for possible future use.
--|
--| Exceptions
--| Scanner_Already_Marked
--|
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.RESTORE . SPEC
-- . .
-- ..............................................
procedure Restore (T : in SCANNER);
--| Purpose
--| Restore the index to the previously marked value
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_WORD . SPEC
-- . .
-- ..............................................
function Is_Word (T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff Scanner is at the start of a word.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_WORD . SPEC
-- . .
-- ..............................................
procedure Scan_word (T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a sequence of non-blank
--| characters. If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_NUMBER . SPEC
-- . .
-- ..............................................
function Is_Number (T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff Scan_Number would return a non-null string (Scanner is
--| at a decimal digit).
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_NUMBER . SPEC
-- . .
-- ..............................................
procedure Scan_Number (T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a sequence of digits.
--| If at least one is found, return Found => TRUE, Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_NUMBER . SPEC
-- . .
-- ..............................................
procedure Scan_Number (T : in SCANNER;
Found : out BOOLEAN;
Result : out INTEGER;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a sequence of digits.
--| If at least one is found, return Found => TRUE, Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_SIGNED_NUMBER . SPEC
-- . .
-- ..............................................
function Is_Signed_Number (T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff Scan_Signed_Number would return a non-null
--| string and Scanner is at a decimal digit or sign (+/-).
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_SIGNED_NUMBER . SPEC
-- . .
-- ..............................................
procedure Scan_Signed_Number (T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a sequence of digits preceeded with optional sign.
--| If at least one digit is found, return Found => TRUE,
--| Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_SIGNED_NUMBER . SPEC
-- . .
-- ..............................................
procedure Scan_Signed_Number (T : in SCANNER;
Found : out BOOLEAN;
Result : out INTEGER;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a sequence of digits preceeded with optional sign.
--| If at least one digit is found, return Found => TRUE,
--| Result => <the digits>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_SPACE . SPEC
-- . .
-- ..............................................
function Is_Space (T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff Scan_Space would return a non-null string.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_SPACE . SPEC
-- . .
-- ..............................................
procedure Scan_Space (T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE);
--| Purpose
--| Scan T past all white space (spaces
--| and tabs. If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SKIP_SPACE . SPEC
-- . .
-- ..............................................
procedure Skip_Space (T : in SCANNER);
--| Purpose
--| Scan T past all white space (spaces and tabs).
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_ADA_ID . SPEC
-- . .
-- ..............................................
function Is_Ada_Id (T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff Scan_Ada_Id would return a non-null string.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_ADA_ID . SPEC
-- . .
-- ..............................................
procedure Scan_Ada_Id (T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a valid Ada identifier.
--| If one is found, return Found => TRUE, Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_QUOTED . SPEC
-- . .
-- ..............................................
function Is_Quoted (T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff T is at a quoted string (eg. ... "Hello" ...).
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_QUOTED . SPEC
-- . .
-- ..............................................
procedure Scan_Quoted (T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan at T for an opening quote
--| followed by a sequence of characters and ending with a closing
--| quote. If successful, return Found => TRUE, Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| A pair of quotes within the quoted string is converted to a single quote.
--| The outer quotes are stripped.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_ENCLOSED . SPEC
-- . .
-- ..............................................
function Is_Enclosed (B : in CHARACTER;
E : in CHARACTER;
T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff T as encosed by B and E (eg. ... [ABC] ...).
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_ENCLOSED . SPEC
-- . .
-- ..............................................
procedure Scan_Enclosed (B : in CHARACTER;
E : in CHARACTER;
T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan at T for an enclosing character
--| followed by a sequence of characters and ending with an enclosing character.
--| If successful, return Found => TRUE, Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| The enclosing characters are stripped.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_SEQUENCE . SPEC
-- . .
-- ..............................................
function Is_Sequence (Chars : in STRING_TYPE;
T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff T is at some character of Chars.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_SEQUENCE . SPEC
-- . .
-- ..............................................
function Is_Sequence (Chars : in STRING;
T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff T is at some character of Chars.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_SEQUENCE . SPEC
-- . .
-- ..............................................
procedure Scan_Sequence (Chars : in STRING_TYPE;
T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a sequence of characters C such that C appears in
--| Char. If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Skip means to skip white characters before scanning.
--|
--| Exceptions (none)
--|
--| Notes
--| Scan_Sequence("0123456789", S, Index, Found, Result)
--| is equivalent to Scan_Number(S, Index, Found, Result)
--| but is less efficient.
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_SEQUENCE . SPEC
-- . .
-- ..............................................
procedure Scan_Sequence (Chars : in STRING;
T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a sequence of characters C such that C appears in
--| Char. If at least one is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Skip means to skip white characters before scanning.
--|
--| Exceptions (none)
--|
--| Notes
--| Scan_Sequence("0123456789", S, Index, Found, Result)
--| is equivalent to Scan_Number(S, Index, Found, Result)
--| but is less efficient.
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_NOT_SEQUENCE . SPEC
-- . .
-- ..............................................
function Is_Not_Sequence (Chars : in STRING_TYPE;
T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff T is not at some character of Chars.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_NOT_SEQUENCE . SPEC
-- . .
-- ..............................................
function Is_Not_Sequence (Chars : in STRING;
T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff T is not at some character of Chars.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_NOT_SEQUENCE . SPEC
-- . .
-- ..............................................
procedure Scan_Not_Sequence (Chars : in STRING_TYPE;
T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a sequence of characters C such that C does not appear
--| in Chars. If at least one such C is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Skip means to skip white characters before scanning.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_NOT_SEQUENCE . SPEC
-- . .
-- ..............................................
procedure Scan_Not_Sequence (Chars : in STRING;
T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a sequence of characters C such that C does not appear
--| in Chars. If at least one such C is found, return Found => TRUE,
--| Result => <the characters>.
--| Otherwise return Found => FALSE and Result is unpredictable.
--| Skip means to skip white characters before scanning.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_LITERAL . SPEC
-- . .
-- ..............................................
function Is_Literal (Chars : in STRING_TYPE;
T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff T is at literal Chars.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_LITERAL . SPEC
-- . .
-- ..............................................
function Is_Literal (Chars : in STRING;
T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff T is at literal Chars.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_LITERAL . SPEC
-- . .
-- ..............................................
procedure Scan_Literal (Chars : in STRING_TYPE;
T : in SCANNER;
Found : out BOOLEAN;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a literal Chars such that Char matches the sequence
--| of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| Skip means to skip white characters before scanning.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_LITERAL . SPEC
-- . .
-- ..............................................
procedure Scan_Literal (Chars : in STRING;
T : in SCANNER;
Found : out BOOLEAN;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a litral Chars such that Char matches the sequence
--| of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| Skip means to skip white characters before scanning.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_NOT_LITERAL . SPEC
-- . .
-- ..............................................
function Is_Not_Literal (Chars : in STRING;
T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff T is not at literal Chars
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.IS_NOT_LITERAL . SPEC
-- . .
-- ..............................................
function Is_Not_Literal (Chars : in STRING_TYPE;
T : in SCANNER) return BOOLEAN;
--| Purpose
--| Return TRUE iff T is not at literal Chars
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_NOT_LITERAL . SPEC
-- . .
-- ..............................................
procedure Scan_Not_Literal (Chars : in STRING;
T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a literal Chars such that Char does not match the
--| sequence of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| Skip means to skip white characters before scanning.
--|
--| Exceptions (none)
--| Notes (none)
-- ..............................................
-- . .
-- . STRING_SCANNER.SCAN_NOT_LITERAL . SPEC
-- . .
-- ..............................................
procedure Scan_Not_Literal (Chars : in STRING_TYPE;
T : in SCANNER;
Found : out BOOLEAN;
Result : out STRING_TYPE;
Skip : in BOOLEAN := FALSE);
--| Purpose
--| Scan T for a litral Chars such that Char does not match the
--| sequence of characters in T. If found, return Found => TRUE,
--| Otherwise return Found => FALSE
--| Skip means to skip white characters before scanning.
--|
--| Exceptions (none)
--| Notes (none)
private
type SCAN_RECORD is
record
Text : STRING_TYPE; -- Copy of string being scanned
Index : POSITIVE := 1; -- Current position of Scanner
Mark : NATURAL := 0; -- Mark
end record;
type SCANNER is access SCAN_RECORD;
end String_Scanner;
--::::::::::
--tod.spc
--::::::::::
-- ****************************************************
-- * *
-- * TOD_UTILITIES * SPEC
-- * *
-- ****************************************************
with Calendar; -- Predefined (internal representation) TOD package.
package TOD_Utilities is
--| Purpose
--| This package will provide direct conversion from an external
--| time/date string to the internal Ada CALENDAR.TIME representation
--| and vice versa. Most free format external representations are
--| supported. Components of an external format include:
--| Year, Month and Day (as numbers and strings), Hour, Minutes,
--| and Seconds
--| As long as the external representation can be parsed unambiguously,
--| this package should be able to handle the conversion. Examples of
--| legal external formats:
--| 7pm Fr March 12, 1982
--| 15 Dec. 84 12:36PM
--| YESTERDAY 3PM
--| 6/01/83 <-- defaults to 12:00:00AM
--| 3:45AM <-- defaults to the current date
--| 18:07:35 <-- defaults to the current date
--| 8-26 <-- defaults to 12:00:00AM of the current year
--| friday <-- defaults to 12:00:00AM of the current or next
--| future Friday
--| Examples of illegal external representations:
--| 2/31/84 <-- February never has a 31st day
--| 12:3605/01/84 <-- too tough to parse (nondeterminstic)
--| 3/8423:00:00 <-- too tough to parse (nondeterminstic)
--| 3:54:29AMTues <-- too tough to parse (nondeterminstic)
--| Nov 1983 <-- must always include day number in the date
--| Sun 8/3/84 <-- 8/3/84 was a Friday
--|
--| Optional periods may be placed after ABBREVIATED day/month names.
--|
--| All external formats are converted to upper case, so there are no
--| problems with specifying mixed and/or lower case input. All
--| results are returned in upper case by default (which can be overridden
--| by specifying lower case or mixed case).
--|
--| Special external formats: TODAY, TOMORROW, YESTERDAY, NOW
--| TODAY is equivalent to 12AM of the current date. TOMORROW and
--| YESTERDAY are equivalent to the next/previous date. NOW is
--| equivalent to calling the function CALENDAR.CLOCK.
--|
--| Defaults:
--| If the year is omitted, it defaults to the current year. If the
--| time is omitted, it defaults to 12:00:00AM. If the day name and no
--| date is specified, the current or next future date is assumed. If
--| only the time is specified, the current date is assumed. If the
--| minutes and/or seconds are not specified in the time, they default
--| to zero. If the year is given in short format (1 or 2 digits) then
--| it defaults to the current century.
--|
--| BNF for the external representation:
--| {<special_format> [<time>] |
--| [<time>] <special_format> |
--| <day_string> &|* <date> &|* <time>}
--|
--| <special_format> ::= {TODAY | TOMORROW | YESTERDAY | NOW}
--|
--| <day_string> ::= SU|NDAY, MO|NDAY, ..., SA|TURDAY
--|
--| <date> ::= {<month_number><sep1><day_number>[<sep1><year_number>] |
--| <month_name><sep2><day_number>[<sep2><year_number>] |
--| <day_number><sep2><month_name>[<sep2><year_number>] |
--| <full_year_number><sep2><month_name><sep2><day_number> |
--| <full_year_number><sep2><day_number><sep2><month_name>}
--|
--| <time> ::= {<hour>':'<minutes>[':'<seconds>][<AM_PM>] |
--| <AMPM_hour><AM_PM>}
--|
--| <month_number> ::= 1 .. 12
--| <month_name> ::= JAN|UARY, FEB|RUARY, ..., DEC|EMBER
--| <day_number> ::= 1 .. 31
--| <year_number> ::= {<short_year_number> | <full_year_number>}
--| <short_year_number> ::= [0]0 .. 99 <-- for century 2000
--| [0]1 .. 99 <-- for century 2100
--| <full_year_number> ::= 1901 .. 2099
--| <sep1> ::= {'-'|'/'}
--| <sep2> ::= {<sep1> | {' ' | ','} ...}
--|
--| <hour> ::= [0]0 .. 24
--| <AMPM_hour> ::= [0]1 .. 12
--| <minutes> ::= 00 .. 59
--| <seconds> ::= 00 .. 59
--| <AM_PM> ::= {"AM" | "PM"}
--|
--| Notes on the BNF above:
--| Items in angle brackets must be separated by at least one
--| blank and/or comma when they appear with exactly one space
--| between them.
--|
--| However, items in angle brackets which are not separated by
--| exactly one blank have a more rigid syntax, and must be followed
--| precisely as specified in the BNF.
--|
--| Some characters/strings are enclosed in quotes to emphasize that
--| they are explicit, and not metasymbols. When specifying an
--| external TOD_String, do NOT include the quotes.
--|
--| The AM/PM indicator may be left off the time if at least the
--| hours and minutes are specified. If only the hour is specified,
--| it must be in the range 01 .. 12 and must have the AM/PM
--| indicator following it. If the AM/PM indicator is left off a
--| time format, AM is assumed unless the hour is in the range
--| 13 .. 23. If the AM/PM indicator is included, the hour must
--| be in the range 01 .. 12.
--|
--| Notation:
--| {...|...|...} -- Select exactly one alternative.
--| [...] -- Optional.
--| &| -- Select one or the other or both,
--| &|* -- Same as &| with the extension of selecting
--| the items in any order.
--| ' ' -- Encloses a character literal.
--| " " -- Encloses a string.
--| < > -- Encloses a non-terminal symbol.
--| ... -- Denotes a repeatable field.
--| | -- Separates alternatives and denotes legal
--| -- abbreviations.
--|
--| Initialization Exceptions (none)
--| Notes (none)
--|
--| Modifications
--| Author: Geoff Mendal, Stanford University
External_TOD_Representation_Length : constant POSITIVE := 38;
subtype EXTERNAL_TOD_REPRESENTATION_TYPE is STRING (
1 .. External_TOD_Representation_Length);
-- This type should be used to retrieve an external TOD
-- representation from the CALENDAR.TIME representation.
type TYPE_SET is (UPPER_CASE, lower_case, Mixed_Case);
-- This type should be used to specify the type set of an
-- external representation returned by the internal-to-external
-- function below.
-- ..................................................
-- . .
-- . TOD_UTILITIES.VERSION . SPEC
-- . .
-- ..................................................
function Version return STRING;
--| Purpose
--| Returns the version number of this package.
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . TOD_UTILITIES.CONVERT . SPEC
-- . .
-- ....................................................
function Convert (
TOD_Value : in CALENDAR.TIME;
Default_Setting : in TYPE_SET := UPPER_CASE)
return EXTERNAL_TOD_REPRESENTATION_TYPE;
--| Purpose
--| The following function will take the CALENDAR.TIME representation
--| and return an external representation. The external representation
--| has the following format:
--| Columns 1 .. 9 : Day as a string
--| Columns 11 .. 12 : Day as a number
--| Columns 14 .. 22 : Month as a string
--| Columns 24 .. 27 : year number
--| Columns 29 .. 38 : time in AM/PM format
--| All unused columns are blank
--|
--| Example string returned:
--| "THURSDAY 09 AUGUST 1984 05:19:05PM"
--|
--| Exceptions (none)
--| Notes (none)
-- ....................................................
-- . .
-- . TOD_UTILITIES.NOW . SPEC
-- . .
-- ....................................................
function Now (Default_Setting : in TYPE_SET := UPPER_CASE)
return EXTERNAL_TOD_REPRESENTATION_TYPE;
--| Purpose
--| This function is a convenience, equivalent to calling
--| the above Convert function with an argument of
--| CALENDAR.CLOCK. The current time and date are
--| returned as specified for Convert above.
--|
--| Exceptions (none)
--| Notes
--| Same as Convert(Calendar.Clock)
-- ....................................................
-- . .
-- . TOD_UTILITIES.CONVERT . SPEC
-- . .
-- ....................................................
function Convert (TOD_String : in STRING) return CALENDAR.TIME;
--| Purpose
--| This function will take an external TOD representation
--| and return the CALENDAR.TIME representation. The external
--| representation can be any STRING object that conforms to
--| the BNF given above.
--|
--| Exceptions (see below)
--| Notes (none)
Duplication_Error, -- "5/25/61 May 25 1961"
Date_Error, -- "2/31/75"
Month_Number_Error, -- "13/1/1960"
Year_Error, -- "1/1/1900"
Day_Number_Error, -- "1/32/1984"
Day_Date_Error, -- "Sunday 8/3/84"
Month_Missing_Error, -- "1961 25"
Day_Number_Missing_Error, -- "1961 May"
Hour_Error, -- "25:00:00"
Minute_Error, -- "23:61:00"
Second_Error, -- "23:59:60"
Time_String_Error, -- "1:05:05:PM"
Abbreviation_Error, -- "Sept.emb. 5"
External_Representation_Error : exception; -- "blah blah blah"
-- These exceptions will be raised if the input to the
-- above function cannot be parsed unambiguously. Also, this function
-- traps CALENDAR.TIME_ERROR and instead raises the exception
-- Date_Error below in its place.
end TOD_Utilities;